Render.hs

{-# 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 updateBuffers recordCommandBuffer = do
  Frame{..} <- asks snd
  let stageRecycled = rrData fRecycledResources
  device <- asks getDevice

  let oneSecondKhr = 1e9
  let
    RecycledResources{..}  = fRecycledResources
    SwapchainResources{..} = fSwapchainResources
    SwapchainInfo{..}      = srInfo

  resourceTRefCount srRelease
  resourceTRefCount (fst fStageResources)
  refcountRenderpass fRenderpass

  updateBuffers stageRecycled

  (res, imageIndex) <- Khr.acquireNextImageKHRSafe
    device
    siSwapchain
    oneSecondKhr
    rrImageAvailableSemaphore
    Vk.NULL_HANDLE

  let
    proceed = do
      -- Allocate a command buffer and populate it
      let
        commandBufferAI = zero
          { Vk.commandPool        = qGraphics rrQueues
          , Vk.level              = Vk.COMMAND_BUFFER_LEVEL_PRIMARY
          , Vk.commandBufferCount = 1
          }
      commandBuffer <- Vk.withCommandBuffers device commandBufferAI Resource.allocate >>= \case
        (_key, [one]) ->
          pure one
        _ ->
          throwString "assert: 1 buffer allocated as requested"

      let
        commandBufferBI = zero
          { CommandBuffer.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT
          }
      Vk.useCommandBuffer commandBuffer commandBufferBI $
        recordCommandBuffer commandBuffer stageRecycled imageIndex

      let
        submitInfo =
          zero
            { Vk.waitSemaphores =
                [ rrImageAvailableSemaphore
                ]
            , Vk.waitDstStageMask =
                [ Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT
                ]
            , Vk.commandBuffers =
                [ Vk.commandBufferHandle commandBuffer
                ]
            , Vk.signalSemaphores =
                [ rrRenderFinishedSemaphore
                , fRenderFinishedHostSemaphore
                ]
            }
          ::& zero
            { Vk12.waitSemaphoreValues   = [1]
            , Vk12.signalSemaphoreValues = [1, fIndex]
            }
          :& ()

      -- traceM $ "Submitting frame " <> textDisplay fIndex <> " to image " <> textDisplay imageIndex
      Queues{qGraphics=(_family, graphicsPresentQueue)} <- asks getQueues
      Frame.queueSubmit
        graphicsPresentQueue
        [SomeStruct submitInfo]
        fGPUWork
        fRenderFinishedHostSemaphore
        fIndex

      -- traceM $ "Presenting image " <> textDisplay imageIndex <> " from frame " <> textDisplay fIndex
      presentRes <- Khr.queuePresentKHR graphicsPresentQueue zero
        { Khr.waitSemaphores = [rrRenderFinishedSemaphore]
        , Khr.swapchains     = [siSwapchain]
        , Khr.imageIndices   = [imageIndex]
        }
      case presentRes of
        Vk.SUCCESS ->
          pure ()
        Vk.SUBOPTIMAL_KHR -> do
          logDebug "[present] Swapchain is suboptimal, forcing update."
          throwM $ VulkanException Vk.ERROR_OUT_OF_DATE_KHR
        _ ->
          -- TODO: check for ERROR_OUT_OF_DATE_KHR
          logWarn $ "Presenting wasn't quite successful: " <> displayShow presentRes

  case res of
    Vk.SUCCESS ->
      -- logDebug $ "Acquired next image ID: " <> displayShow imageIndex
      proceed

    Vk.TIMEOUT ->
      logDebug "Timed out (1s) trying to acquire next image"

    Vk.ERROR_OUT_OF_DATE_KHR -> do
      {- XXX:
        Throwing an exception for 'Engine.Vulkan.Swapchain.threwSwapchainError' to catch.
        See also: 'Engine.Run.step'.
      -}
      logDebug "[acquire] Swapchain out of date"
      throwM $ VulkanException res

    Vk.SUBOPTIMAL_KHR -> do
      {- XXX:
        Converting 'Vk.SUBOPTIMAL_KHR' error to OOD to trigger swapchain update.
      -}
      logDebug "[acquire] Swapchain is suboptimal, forcing update."
      throwM $ VulkanException Vk.ERROR_OUT_OF_DATE_KHR

    _ -> do
      logError $
        "Unexpected Result from acquireNextImageKHR: " <>
        fromString (show res)
      throwM $ VulkanException res