{-# LANGUAGE OverloadedLists #-}
module Engine.Render where
import RIO
import Vulkan.Exception (VulkanException(..))
import Control.Monad.Trans.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.Core10.CommandBuffer qualified as CommandBuffer
import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore qualified as Vk12
import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&))
import Vulkan.Extensions.VK_KHR_swapchain qualified as Khr
import Vulkan.NamedType ((:::))
import Vulkan.Zero (zero)
import Engine.Frame qualified as Frame
import Engine.Types (Frame(..), RecycledResources(..), StageFrameRIO)
import Engine.Types.RefCounted (resourceTRefCount)
import Engine.Vulkan.Swapchain (SwapchainInfo(..), SwapchainResources(..))
import Engine.Vulkan.Types (HasVulkan(..), RenderPass(..), Queues(..))
renderFrame
:: RenderPass rp
=> (rr -> StageFrameRIO rp p rr st ())
-> (Vk.CommandBuffer -> rr -> "image index" ::: Word32 -> StageFrameRIO rp p rr st ())
-> StageFrameRIO rp p rr st ()
renderFrame :: forall rp rr p st.
RenderPass rp =>
(rr -> StageFrameRIO rp p rr st ())
-> (CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ())
-> StageFrameRIO rp p rr st ()
renderFrame rr -> StageFrameRIO rp p rr st ()
updateBuffers CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
recordCommandBuffer = do
Frame{rp
p
Maybe PresentModeKHR
Word64
(ReleaseKey, InternalState)
(RefCounted, InternalState)
Window
IORef [GPUWork]
SurfaceKHR
Semaphore
SampleCountFlagBits
SwapchainResources
RecycledResources rr
$sel:fRecycledResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> RecycledResources resources
$sel:fResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (ReleaseKey, InternalState)
$sel:fGPUWork:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> IORef [GPUWork]
$sel:fStageResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
$sel:fRenderFinishedHostSemaphore:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Semaphore
$sel:fPipelines:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> pipelines
$sel:fRenderpass:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> renderpass
$sel:fSwapchainResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
$sel:fMSAA:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SampleCountFlagBits
$sel:fPresent:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Maybe PresentModeKHR
$sel:fSurface:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SurfaceKHR
$sel:fWindow:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
$sel:fIndex:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
fRecycledResources :: RecycledResources rr
fResources :: (ReleaseKey, InternalState)
fGPUWork :: IORef [GPUWork]
fStageResources :: (RefCounted, InternalState)
fRenderFinishedHostSemaphore :: Semaphore
fPipelines :: p
fRenderpass :: rp
fSwapchainResources :: SwapchainResources
fMSAA :: SampleCountFlagBits
fPresent :: Maybe PresentModeKHR
fSurface :: SurfaceKHR
fWindow :: Window
fIndex :: Word64
..} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a, b) -> b
snd
let stageRecycled :: rr
stageRecycled = forall a. RecycledResources a -> a
rrData RecycledResources rr
fRecycledResources
Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
let oneSecondKhr :: Word64
oneSecondKhr = Word64
1e9
let
RecycledResources{rr
Semaphore
Queues CommandPool
$sel:rrQueues:RecycledResources :: forall a. RecycledResources a -> Queues CommandPool
$sel:rrRenderFinishedSemaphore:RecycledResources :: forall a. RecycledResources a -> Semaphore
$sel:rrImageAvailableSemaphore:RecycledResources :: forall a. RecycledResources a -> Semaphore
rrData :: rr
rrQueues :: Queues CommandPool
rrRenderFinishedSemaphore :: Semaphore
rrImageAvailableSemaphore :: Semaphore
$sel:rrData:RecycledResources :: forall a. RecycledResources a -> a
..} = RecycledResources rr
fRecycledResources
SwapchainResources{Var Extent2D
Vector Image
Vector ImageView
RefCounted
SwapchainInfo
$sel:srScreenVar:SwapchainResources :: SwapchainResources -> Var Extent2D
$sel:srRelease:SwapchainResources :: SwapchainResources -> RefCounted
$sel:srImages:SwapchainResources :: SwapchainResources -> Vector Image
$sel:srImageViews:SwapchainResources :: SwapchainResources -> Vector ImageView
$sel:srInfo:SwapchainResources :: SwapchainResources -> SwapchainInfo
srScreenVar :: Var Extent2D
srRelease :: RefCounted
srImages :: Vector Image
srImageViews :: Vector ImageView
srInfo :: SwapchainInfo
..} = SwapchainResources
fSwapchainResources
SwapchainInfo{Float
"image index" ::: Word32
ReleaseKey
ColorSpaceKHR
PresentModeKHR
SurfaceKHR
SwapchainKHR
Extent2D
SampleCountFlagBits
Format
$sel:siSurface:SwapchainInfo :: SwapchainInfo -> SurfaceKHR
$sel:siImageExtent:SwapchainInfo :: SwapchainInfo -> Extent2D
$sel:siAnisotropy:SwapchainInfo :: SwapchainInfo -> Float
$sel:siMultisample:SwapchainInfo :: SwapchainInfo -> SampleCountFlagBits
$sel:siDepthFormat:SwapchainInfo :: SwapchainInfo -> Format
$sel:siSurfaceColorspace:SwapchainInfo :: SwapchainInfo -> ColorSpaceKHR
$sel:siSurfaceFormat:SwapchainInfo :: SwapchainInfo -> Format
$sel:siMinImageCount:SwapchainInfo :: SwapchainInfo -> "image index" ::: Word32
$sel:siPresentMode:SwapchainInfo :: SwapchainInfo -> PresentModeKHR
$sel:siSwapchainReleaseKey:SwapchainInfo :: SwapchainInfo -> ReleaseKey
$sel:siSwapchain:SwapchainInfo :: SwapchainInfo -> SwapchainKHR
siSurface :: SurfaceKHR
siImageExtent :: Extent2D
siAnisotropy :: Float
siMultisample :: SampleCountFlagBits
siDepthFormat :: Format
siSurfaceColorspace :: ColorSpaceKHR
siSurfaceFormat :: Format
siMinImageCount :: "image index" ::: Word32
siPresentMode :: PresentModeKHR
siSwapchainReleaseKey :: ReleaseKey
siSwapchain :: SwapchainKHR
..} = SwapchainInfo
srInfo
forall (f :: * -> *). MonadResource f => RefCounted -> f ()
resourceTRefCount RefCounted
srRelease
forall (f :: * -> *). MonadResource f => RefCounted -> f ()
resourceTRefCount (forall a b. (a, b) -> a
fst (RefCounted, InternalState)
fStageResources)
forall a env.
(RenderPass a, MonadResource (RIO env)) =>
a -> RIO env ()
refcountRenderpass rp
fRenderpass
rr -> StageFrameRIO rp p rr st ()
updateBuffers rr
stageRecycled
(Result
res, "image index" ::: Word32
imageIndex) <- forall (io :: * -> *).
MonadIO io =>
Device
-> SwapchainKHR
-> Word64
-> Semaphore
-> Fence
-> io (Result, "image index" ::: Word32)
Khr.acquireNextImageKHRSafe
Device
device
SwapchainKHR
siSwapchain
Word64
oneSecondKhr
Semaphore
rrImageAvailableSemaphore
forall a. IsHandle a => a
Vk.NULL_HANDLE
let
proceed :: StageFrameRIO rp p rr st ()
proceed = do
let
commandBufferAI :: CommandBufferAllocateInfo
commandBufferAI = forall a. Zero a => a
zero
{ $sel:commandPool:CommandBufferAllocateInfo :: CommandPool
Vk.commandPool = forall q. Queues q -> q
qGraphics Queues CommandPool
rrQueues
, $sel:level:CommandBufferAllocateInfo :: CommandBufferLevel
Vk.level = CommandBufferLevel
Vk.COMMAND_BUFFER_LEVEL_PRIMARY
, $sel:commandBufferCount:CommandBufferAllocateInfo :: "image index" ::: Word32
Vk.commandBufferCount = "image index" ::: Word32
1
}
CommandBuffer
commandBuffer <- forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandBufferAllocateInfo
-> (io (Vector CommandBuffer)
-> (Vector CommandBuffer -> io ()) -> r)
-> r
Vk.withCommandBuffers Device
device CommandBufferAllocateInfo
commandBufferAI forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(ReleaseKey
_key, [Item (Vector CommandBuffer)
one]) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Item (Vector CommandBuffer)
one
(ReleaseKey, Vector CommandBuffer)
_ ->
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"assert: 1 buffer allocated as requested"
let
commandBufferBI :: CommandBufferBeginInfo '[]
commandBufferBI = forall a. Zero a => a
zero
{ $sel:flags:CommandBufferBeginInfo :: CommandBufferUsageFlags
CommandBuffer.flags = CommandBufferUsageFlags
Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT
}
forall (a :: [*]) (io :: * -> *) r.
(Extendss CommandBufferBeginInfo a, PokeChain a, MonadIO io) =>
CommandBuffer -> CommandBufferBeginInfo a -> io r -> io r
Vk.useCommandBuffer CommandBuffer
commandBuffer CommandBufferBeginInfo '[]
commandBufferBI forall a b. (a -> b) -> a -> b
$
CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
recordCommandBuffer CommandBuffer
commandBuffer rr
stageRecycled "image index" ::: Word32
imageIndex
let
submitInfo :: SubmitInfo '[TimelineSemaphoreSubmitInfo]
submitInfo =
forall a. Zero a => a
zero
{ $sel:waitSemaphores:SubmitInfo :: Vector Semaphore
Vk.waitSemaphores =
[ Semaphore
rrImageAvailableSemaphore
]
, $sel:waitDstStageMask:SubmitInfo :: Vector PipelineStageFlags
Vk.waitDstStageMask =
[ PipelineStageFlags
Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
]
, $sel:commandBuffers:SubmitInfo :: Vector (Ptr CommandBuffer_T)
Vk.commandBuffers =
[ CommandBuffer -> Ptr CommandBuffer_T
Vk.commandBufferHandle CommandBuffer
commandBuffer
]
, $sel:signalSemaphores:SubmitInfo :: Vector Semaphore
Vk.signalSemaphores =
[ Semaphore
rrRenderFinishedSemaphore
, Semaphore
fRenderFinishedHostSemaphore
]
}
forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& forall a. Zero a => a
zero
{ $sel:waitSemaphoreValues:TimelineSemaphoreSubmitInfo :: Vector Word64
Vk12.waitSemaphoreValues = [Word64
1]
, $sel:signalSemaphoreValues:TimelineSemaphoreSubmitInfo :: Vector Word64
Vk12.signalSemaphoreValues = [Word64
1, Word64
fIndex]
}
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ()
Queues{$sel:qGraphics:Queues :: forall q. Queues q -> q
qGraphics=(QueueFamilyIndex
_family, Queue
graphicsPresentQueue)} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Queues (QueueFamilyIndex, Queue)
getQueues
forall env (m :: * -> *).
MonadVulkan env m =>
Queue
-> Vector (SomeStruct SubmitInfo)
-> IORef [GPUWork]
-> Semaphore
-> Word64
-> m ()
Frame.queueSubmit
Queue
graphicsPresentQueue
[forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct SubmitInfo '[TimelineSemaphoreSubmitInfo]
submitInfo]
IORef [GPUWork]
fGPUWork
Semaphore
fRenderFinishedHostSemaphore
Word64
fIndex
Result
presentRes <- forall (a :: [*]) (io :: * -> *).
(Extendss PresentInfoKHR a, PokeChain a, MonadIO io) =>
Queue -> PresentInfoKHR a -> io Result
Khr.queuePresentKHR Queue
graphicsPresentQueue forall a. Zero a => a
zero
{ $sel:waitSemaphores:PresentInfoKHR :: Vector Semaphore
Khr.waitSemaphores = [Semaphore
rrRenderFinishedSemaphore]
, $sel:swapchains:PresentInfoKHR :: Vector SwapchainKHR
Khr.swapchains = [SwapchainKHR
siSwapchain]
, $sel:imageIndices:PresentInfoKHR :: Vector ("image index" ::: Word32)
Khr.imageIndices = ["image index" ::: Word32
imageIndex]
}
case Result
presentRes of
Result
Vk.SUCCESS ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Result
Vk.SUBOPTIMAL_KHR -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"[present] Swapchain is suboptimal, forcing update."
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
Vk.ERROR_OUT_OF_DATE_KHR
Result
_ ->
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Presenting wasn't quite successful: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Result
presentRes
case Result
res of
Result
Vk.SUCCESS ->
StageFrameRIO rp p rr st ()
proceed
Result
Vk.TIMEOUT ->
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Timed out (1s) trying to acquire next image"
Result
Vk.ERROR_OUT_OF_DATE_KHR -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"[acquire] Swapchain out of date"
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
res
Result
Vk.SUBOPTIMAL_KHR -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"[acquire] Swapchain is suboptimal, forcing update."
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
Vk.ERROR_OUT_OF_DATE_KHR
Result
_ -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Unexpected Result from acquireNextImageKHR: " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show Result
res)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
res