{-# 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.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
Word64
(ReleaseKey, InternalState)
(RefCounted, InternalState)
Window
IORef [GPUWork]
SurfaceKHR
Semaphore
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: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
fSurface :: SurfaceKHR
fWindow :: Window
fIndex :: Word64
..} <- ((App GlobalHandles st, Frame rp p rr) -> Frame rp p rr)
-> RIO (App GlobalHandles st, Frame rp p rr) (Frame rp p rr)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (App GlobalHandles st, Frame rp p rr) -> Frame rp p rr
forall a b. (a, b) -> b
snd
let stageRecycled :: rr
stageRecycled = RecycledResources rr -> rr
forall a. RecycledResources a -> a
rrData RecycledResources rr
fRecycledResources
Device
device <- ((App GlobalHandles st, Frame rp p rr) -> Device)
-> RIO (App GlobalHandles st, Frame rp p rr) Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (App GlobalHandles st, Frame rp p rr) -> Device
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
RefCounted -> StageFrameRIO rp p rr st ()
forall (f :: * -> *). MonadResource f => RefCounted -> f ()
resourceTRefCount RefCounted
srRelease
RefCounted -> StageFrameRIO rp p rr st ()
forall (f :: * -> *). MonadResource f => RefCounted -> f ()
resourceTRefCount ((RefCounted, InternalState) -> RefCounted
forall a b. (a, b) -> a
fst (RefCounted, InternalState)
fStageResources)
rp -> StageFrameRIO rp p rr st ()
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) <- Device
-> SwapchainKHR
-> Word64
-> Semaphore
-> Fence
-> RIO
(App GlobalHandles st, Frame rp p rr)
(Result, "image index" ::: Word32)
forall (io :: * -> *).
MonadIO io =>
Device
-> SwapchainKHR
-> Word64
-> Semaphore
-> Fence
-> io (Result, "image index" ::: Word32)
Khr.acquireNextImageKHRSafe
Device
device
SwapchainKHR
siSwapchain
Word64
oneSecondKhr
Semaphore
rrImageAvailableSemaphore
Fence
forall a. IsHandle a => a
Vk.NULL_HANDLE
let
proceed :: StageFrameRIO rp p rr st ()
proceed = do
let
commandBufferAI :: CommandBufferAllocateInfo
commandBufferAI = CommandBufferAllocateInfo
forall a. Zero a => a
zero
{ $sel:commandPool:CommandBufferAllocateInfo :: CommandPool
Vk.commandPool = Queues CommandPool -> 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 <- Device
-> CommandBufferAllocateInfo
-> (IO (Vector CommandBuffer)
-> (Vector CommandBuffer -> IO ())
-> RIO
(App GlobalHandles st, Frame rp p rr)
(ReleaseKey, Vector CommandBuffer))
-> RIO
(App GlobalHandles st, Frame rp p rr)
(ReleaseKey, Vector CommandBuffer)
forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandBufferAllocateInfo
-> (io (Vector CommandBuffer)
-> (Vector CommandBuffer -> io ()) -> r)
-> r
Vk.withCommandBuffers Device
device CommandBufferAllocateInfo
commandBufferAI IO (Vector CommandBuffer)
-> (Vector CommandBuffer -> IO ())
-> RIO
(App GlobalHandles st, Frame rp p rr)
(ReleaseKey, Vector CommandBuffer)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate RIO
(App GlobalHandles st, Frame rp p rr)
(ReleaseKey, Vector CommandBuffer)
-> ((ReleaseKey, Vector CommandBuffer)
-> RIO (App GlobalHandles st, Frame rp p rr) CommandBuffer)
-> RIO (App GlobalHandles st, Frame rp p rr) CommandBuffer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(ReleaseKey
_key, [Item (Vector CommandBuffer)
one]) ->
CommandBuffer
-> RIO (App GlobalHandles st, Frame rp p rr) CommandBuffer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Item (Vector CommandBuffer)
CommandBuffer
one
(ReleaseKey, Vector CommandBuffer)
_ ->
String -> RIO (App GlobalHandles st, Frame rp p rr) CommandBuffer
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"assert: 1 buffer allocated as requested"
let
commandBufferBI :: CommandBufferBeginInfo '[]
commandBufferBI = CommandBufferBeginInfo '[]
forall a. Zero a => a
zero
{ $sel:flags:CommandBufferBeginInfo :: CommandBufferUsageFlags
Vk.flags = CommandBufferUsageFlags
Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT
} :: Vk.CommandBufferBeginInfo '[]
CommandBuffer
-> CommandBufferBeginInfo '[]
-> StageFrameRIO rp p rr st ()
-> StageFrameRIO rp p rr st ()
forall (a :: [*]) (io :: * -> *) r.
(Extendss CommandBufferBeginInfo a, PokeChain a, MonadIO io) =>
CommandBuffer -> CommandBufferBeginInfo a -> io r -> io r
Vk.useCommandBuffer CommandBuffer
commandBuffer CommandBufferBeginInfo '[]
commandBufferBI (StageFrameRIO rp p rr st () -> StageFrameRIO rp p rr st ())
-> StageFrameRIO rp p rr st () -> StageFrameRIO rp p rr st ()
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 =
SubmitInfo '[]
forall a. Zero a => a
zero
{ $sel:waitSemaphores:SubmitInfo :: Vector Semaphore
Vk.waitSemaphores =
[ Item (Vector Semaphore)
Semaphore
rrImageAvailableSemaphore
]
, $sel:waitDstStageMask:SubmitInfo :: Vector PipelineStageFlags
Vk.waitDstStageMask =
[ Item (Vector PipelineStageFlags)
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 =
[ Item (Vector Semaphore)
Semaphore
rrRenderFinishedSemaphore
, Item (Vector Semaphore)
Semaphore
fRenderFinishedHostSemaphore
]
}
SubmitInfo '[]
-> Chain '[TimelineSemaphoreSubmitInfo]
-> SubmitInfo '[TimelineSemaphoreSubmitInfo]
forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& TimelineSemaphoreSubmitInfo
forall a. Zero a => a
zero
{ $sel:waitSemaphoreValues:TimelineSemaphoreSubmitInfo :: Vector Word64
Vk12.waitSemaphoreValues = [Item (Vector Word64)
1]
, $sel:signalSemaphoreValues:TimelineSemaphoreSubmitInfo :: Vector Word64
Vk12.signalSemaphoreValues = [Item (Vector Word64)
1, Word64
Item (Vector Word64)
fIndex]
}
TimelineSemaphoreSubmitInfo
-> Chain '[] -> Chain '[TimelineSemaphoreSubmitInfo]
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ()
Queues{$sel:qGraphics:Queues :: forall q. Queues q -> q
qGraphics=(QueueFamilyIndex
_family, Queue
graphicsPresentQueue)} <- ((App GlobalHandles st, Frame rp p rr)
-> Queues (QueueFamilyIndex, Queue))
-> RIO
(App GlobalHandles st, Frame rp p rr)
(Queues (QueueFamilyIndex, Queue))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (App GlobalHandles st, Frame rp p rr)
-> Queues (QueueFamilyIndex, Queue)
forall a. HasVulkan a => a -> Queues (QueueFamilyIndex, Queue)
getQueues
Queue
-> Vector (SomeStruct SubmitInfo)
-> IORef [GPUWork]
-> Semaphore
-> Word64
-> StageFrameRIO rp p rr st ()
forall env (m :: * -> *).
MonadVulkan env m =>
Queue
-> Vector (SomeStruct SubmitInfo)
-> IORef [GPUWork]
-> Semaphore
-> Word64
-> m ()
Frame.queueSubmit
Queue
graphicsPresentQueue
[SubmitInfo '[TimelineSemaphoreSubmitInfo] -> SomeStruct SubmitInfo
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 <- Queue
-> PresentInfoKHR '[]
-> RIO (App GlobalHandles st, Frame rp p rr) Result
forall (a :: [*]) (io :: * -> *).
(Extendss PresentInfoKHR a, PokeChain a, MonadIO io) =>
Queue -> PresentInfoKHR a -> io Result
Khr.queuePresentKHR Queue
graphicsPresentQueue PresentInfoKHR '[]
forall a. Zero a => a
zero
{ $sel:waitSemaphores:PresentInfoKHR :: Vector Semaphore
Khr.waitSemaphores = [Item (Vector Semaphore)
Semaphore
rrRenderFinishedSemaphore]
, $sel:swapchains:PresentInfoKHR :: Vector SwapchainKHR
Khr.swapchains = [Item (Vector SwapchainKHR)
SwapchainKHR
siSwapchain]
, $sel:imageIndices:PresentInfoKHR :: Vector ("image index" ::: Word32)
Khr.imageIndices = ["image index" ::: Word32
Item (Vector ("image index" ::: Word32))
imageIndex]
}
case Result
presentRes of
Result
Vk.SUCCESS ->
() -> StageFrameRIO rp p rr st ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Result
Vk.SUBOPTIMAL_KHR -> do
Utf8Builder -> StageFrameRIO rp p rr st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"[present] Swapchain is suboptimal, forcing update."
VulkanException -> StageFrameRIO rp p rr st ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VulkanException -> StageFrameRIO rp p rr st ())
-> VulkanException -> StageFrameRIO rp p rr st ()
forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
Vk.ERROR_OUT_OF_DATE_KHR
Result
_ ->
Utf8Builder -> StageFrameRIO rp p rr st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> StageFrameRIO rp p rr st ())
-> Utf8Builder -> StageFrameRIO rp p rr st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Presenting wasn't quite successful: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Result -> Utf8Builder
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 ->
Utf8Builder -> StageFrameRIO rp p rr st ()
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
Utf8Builder -> StageFrameRIO rp p rr st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"[acquire] Swapchain out of date"
VulkanException -> StageFrameRIO rp p rr st ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VulkanException -> StageFrameRIO rp p rr st ())
-> VulkanException -> StageFrameRIO rp p rr st ()
forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
res
Result
Vk.SUBOPTIMAL_KHR -> do
Utf8Builder -> StageFrameRIO rp p rr st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"[acquire] Swapchain is suboptimal, forcing update."
VulkanException -> StageFrameRIO rp p rr st ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VulkanException -> StageFrameRIO rp p rr st ())
-> VulkanException -> StageFrameRIO rp p rr st ()
forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
Vk.ERROR_OUT_OF_DATE_KHR
Result
_ -> do
Utf8Builder -> StageFrameRIO rp p rr st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> StageFrameRIO rp p rr st ())
-> Utf8Builder -> StageFrameRIO rp p rr st ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Unexpected Result from acquireNextImageKHR: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Result -> String
forall a. Show a => a -> String
show Result
res)
VulkanException -> StageFrameRIO rp p rr st ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (VulkanException -> StageFrameRIO rp p rr st ())
-> VulkanException -> StageFrameRIO rp p rr st ()
forall a b. (a -> b) -> a -> b
$ Result -> VulkanException
VulkanException Result
res