module Engine.Frame
  ( Frame(..)
  , initial
  , run
  , advance
  , queueSubmit

  , RecycledResources(..)
  , initialRecycledResources
  , timeoutError
  ) where

import RIO

import Control.Monad.Trans.Resource (ResourceT, MonadResource, allocate, release)
import Control.Monad.Trans.Resource qualified as ResourceT
import GHC.IO.Exception (IOErrorType(TimeExpired), IOException(IOError))
import RIO.App (appEnv)
import RIO.Text qualified as Text
import RIO.Vector qualified as Vector
import UnliftIO.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.NamedType ((:::))
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))
import Vulkan.Zero (zero)

import Engine.DataRecycler (DumpResource, WaitResource)
import Engine.Setup.Window qualified as Window
import Engine.Types (GlobalHandles(..), StageRIO, Stage(..), Frame(..), GPUWork, RecycledResources(..))
import Engine.Types.Options (optionsPresent, optionsMsaa)
import Engine.Types.RefCounted (newRefCounted)
import Engine.Vulkan.Swapchain (SwapchainResources(..), SwapchainInfo(..), allocSwapchainResources, recreateSwapchainResources)
import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, RenderPass(..), Queues)

initial
  :: Maybe SwapchainResources
  -> DumpResource (RecycledResources rr)
  -> Stage rp p rr st
  -> StageRIO st (Frame rp p rr)
initial :: forall rr rp p st.
Maybe SwapchainResources
-> DumpResource (RecycledResources rr)
-> Stage rp p rr st
-> StageRIO st (Frame rp p rr)
initial Maybe SwapchainResources
oldSR DumpResource (RecycledResources rr)
dumpResource Stage{Text
StageRIO st a
StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
st -> rr -> StageFrameRIO rp p rr st ()
a -> StageRIO st ()
CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
Queues CommandPool
-> rp -> p -> ResourceT (RIO (App GlobalHandles st)) rr
SwapchainResources -> ResourceT (RIO (App GlobalHandles st)) rp
SwapchainResources
-> rp -> ResourceT (RIO (App GlobalHandles st)) p
$sel:sAfterLoop:Stage :: ()
$sel:sRecordCommands:Stage :: forall rp p rr st.
Stage rp p rr st
-> CommandBuffer
-> rr
-> ("image index" ::: Word32)
-> StageFrameRIO rp p rr st ()
$sel:sUpdateBuffers:Stage :: forall rp p rr st.
Stage rp p rr st -> st -> rr -> StageFrameRIO rp p rr st ()
$sel:sBeforeLoop:Stage :: ()
$sel:sInitialRR:Stage :: forall rp p rr st.
Stage rp p rr st
-> Queues CommandPool -> rp -> p -> ResourceT (StageRIO st) rr
$sel:sInitialRS:Stage :: forall rp p rr st.
Stage rp p rr st
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
$sel:sAllocateP:Stage :: forall rp p rr st.
Stage rp p rr st
-> SwapchainResources -> rp -> ResourceT (StageRIO st) p
$sel:sAllocateRP:Stage :: forall rp p rr st.
Stage rp p rr st
-> SwapchainResources -> ResourceT (StageRIO st) rp
$sel:sTitle:Stage :: forall rp p rr st. Stage rp p rr st -> Text
sAfterLoop :: a -> StageRIO st ()
sRecordCommands :: CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
sUpdateBuffers :: st -> rr -> StageFrameRIO rp p rr st ()
sBeforeLoop :: StageRIO st a
sInitialRR :: Queues CommandPool
-> rp -> p -> ResourceT (RIO (App GlobalHandles st)) rr
sInitialRS :: StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
sAllocateP :: SwapchainResources
-> rp -> ResourceT (RIO (App GlobalHandles st)) p
sAllocateRP :: SwapchainResources -> ResourceT (RIO (App GlobalHandles st)) rp
sTitle :: Text
..} = do
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Making initial frame"

  GlobalHandles{Window
Allocator
Var Extent2D
StageSwitchVar
SurfaceKHR
Device
Instance
PhysicalDevice
PhysicalDeviceInfo
Queues (QueueFamilyIndex, Queue)
Options
$sel:ghStageSwitch:GlobalHandles :: GlobalHandles -> StageSwitchVar
$sel:ghScreenVar:GlobalHandles :: GlobalHandles -> Var Extent2D
$sel:ghQueues:GlobalHandles :: GlobalHandles -> Queues (QueueFamilyIndex, Queue)
$sel:ghAllocator:GlobalHandles :: GlobalHandles -> Allocator
$sel:ghDevice:GlobalHandles :: GlobalHandles -> Device
$sel:ghPhysicalDeviceInfo:GlobalHandles :: GlobalHandles -> PhysicalDeviceInfo
$sel:ghPhysicalDevice:GlobalHandles :: GlobalHandles -> PhysicalDevice
$sel:ghInstance:GlobalHandles :: GlobalHandles -> Instance
$sel:ghSurface:GlobalHandles :: GlobalHandles -> SurfaceKHR
$sel:ghWindow:GlobalHandles :: GlobalHandles -> Window
$sel:ghOptions:GlobalHandles :: GlobalHandles -> Options
ghStageSwitch :: StageSwitchVar
ghScreenVar :: Var Extent2D
ghQueues :: Queues (QueueFamilyIndex, Queue)
ghAllocator :: Allocator
ghDevice :: Device
ghPhysicalDeviceInfo :: PhysicalDeviceInfo
ghPhysicalDevice :: PhysicalDevice
ghInstance :: Instance
ghSurface :: SurfaceKHR
ghWindow :: Window
ghOptions :: Options
..} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall env st. App env st -> env
appEnv
  let device :: Device
device = Device
ghDevice

  let
    fPresent :: Maybe PresentModeKHR
fPresent = Options -> Maybe PresentModeKHR
optionsPresent Options
ghOptions
    fMSAA :: SampleCountFlagBits
fMSAA = Options -> SampleCountFlagBits
optionsMsaa Options
ghOptions

  SwapchainResources
sfSwapchainResources <- case Maybe SwapchainResources
oldSR of
    Maybe SwapchainResources
Nothing -> do
      Extent2D
windowSize <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Window -> IO Extent2D
Window.getExtent2D Window
ghWindow
      let oldSwapchain :: SwapchainKHR
oldSwapchain = forall a. IsHandle a => a
Vk.NULL_HANDLE
      forall env.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
Maybe PresentModeKHR
-> SampleCountFlagBits
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> Var Extent2D
-> RIO env SwapchainResources
allocSwapchainResources
        Maybe PresentModeKHR
fPresent
        SampleCountFlagBits
fMSAA
        SwapchainKHR
oldSwapchain
        Extent2D
windowSize
        SurfaceKHR
ghSurface
        Var Extent2D
ghScreenVar
    Just SwapchainResources
old ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure SwapchainResources
old

  {- XXX:
    Create this resource object at the global level so it's closed correctly on exception.
  -}
  (ReleaseKey
stageKey, InternalState
stageResources) <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate forall (m :: * -> *). MonadIO m => m InternalState
ResourceT.createInternalState forall (m :: * -> *). MonadIO m => InternalState -> m ()
ResourceT.closeInternalState
  RefCounted
stageRefCounted <- forall (m :: * -> *). MonadIO m => IO () -> m RefCounted
newRefCounted forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
stageKey
  (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
semiFrame <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
ResourceT.runInternalState InternalState
stageResources do
    {- XXX:
      Stages appearing on the top of the stage stack are to create their swapchain-derived resources.
      Don't keep the release keys, all resources here are refcounted and live for the lifetime of the stage.
      Resources will be released when the stage is finished or suspended and all the frames are done.
    -}

    IO ()
debugAlloc <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Allocating inside stage " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
    IO ()
debugRelease <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Releasing inside stage " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *) a.
MonadResource m =>
IO a -> IO () -> m ReleaseKey
ResourceT.allocate_ IO ()
debugAlloc IO ()
debugRelease

    -- For each render pass:
    rp
sfRenderpass <- SwapchainResources -> ResourceT (RIO (App GlobalHandles st)) rp
sAllocateRP SwapchainResources
sfSwapchainResources

    -- TODO: Recreate this if the swapchain format changes
    p
sfPipelines <- SwapchainResources
-> rp -> ResourceT (RIO (App GlobalHandles st)) p
sAllocateP SwapchainResources
sfSwapchainResources rp
sfRenderpass

    (ReleaseKey
_, Semaphore
sfRenderFinishedHostSemaphore) <- forall (a :: [*]) (io :: * -> *) r.
(Extendss SemaphoreCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> SemaphoreCreateInfo a
-> Maybe AllocationCallbacks
-> (io Semaphore -> (Semaphore -> io ()) -> r)
-> r
Vk.withSemaphore
      Device
device
      (forall a. Zero a => a
zero forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& SemaphoreType -> Word64 -> SemaphoreTypeCreateInfo
Vk12.SemaphoreTypeCreateInfo SemaphoreType
Vk12.SEMAPHORE_TYPE_TIMELINE Word64
0 forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ())
      forall a. Maybe a
Nothing
      forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate

    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Creating initial recycled resources for stage " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
    RecycledResources rr
sfRecycledResources <- forall env rp p rr.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
(Queues CommandPool -> rp -> p -> ResourceT (RIO env) rr)
-> rp -> p -> ResourceT (RIO env) (RecycledResources rr)
initialRecycledResources Queues CommandPool
-> rp -> p -> ResourceT (RIO (App GlobalHandles st)) rr
sInitialRR rp
sfRenderpass p
sfPipelines
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (forall a. (Eq a, Num a) => a
INFLIGHT_FRAMES forall a. Num a => a -> a -> a
- Int
1) do
      RecycledResources rr
resources <- forall env rp p rr.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
(Queues CommandPool -> rp -> p -> ResourceT (RIO env) rr)
-> rp -> p -> ResourceT (RIO env) (RecycledResources rr)
initialRecycledResources Queues CommandPool
-> rp -> p -> ResourceT (RIO (App GlobalHandles st)) rr
sInitialRR rp
sfRenderpass p
sfPipelines
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DumpResource (RecycledResources rr)
dumpResource RecycledResources rr
resources

    IO ()
releaseDataDebug <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Releasing recycled resources for stage " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register IO ()
releaseDataDebug

    pure
      ( SwapchainResources
sfSwapchainResources
      , rp
sfRenderpass
      , p
sfPipelines
      , Semaphore
sfRenderFinishedHostSemaphore
      , RecycledResources rr
sfRecycledResources
      )

  let
    (SwapchainResources
fSwapchainResources, rp
fRenderpass, p
fPipelines, Semaphore
fRenderFinishedHostSemaphore, RecycledResources rr
fRecycledResources) = (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
semiFrame

  {- XXX:
    Create this resource object at the global level so it's closed correctly on exception.
    Recycled frame resources can linger for a bit longer after its stage is gone, thus 'RefCounted'.
  -}
  (ReleaseKey, InternalState)
fResources <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate forall (m :: * -> *). MonadIO m => m InternalState
ResourceT.createInternalState forall (m :: * -> *). MonadIO m => InternalState -> m ()
ResourceT.closeInternalState

  IORef [GPUWork]
fGPUWork <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Monoid a => a
mempty

  pure Frame
    { $sel:fIndex:Frame :: Word64
fIndex          = Word64
1
    , $sel:fWindow:Frame :: Window
fWindow         = Window
ghWindow
    , $sel:fSurface:Frame :: SurfaceKHR
fSurface        = SurfaceKHR
ghSurface
    , $sel:fStageResources:Frame :: (RefCounted, InternalState)
fStageResources = (RefCounted
stageRefCounted, InternalState
stageResources)
    , rp
p
Maybe PresentModeKHR
(ReleaseKey, InternalState)
IORef [GPUWork]
Semaphore
SampleCountFlagBits
SwapchainResources
RecycledResources rr
$sel:fRecycledResources:Frame :: RecycledResources rr
$sel:fResources:Frame :: (ReleaseKey, InternalState)
$sel:fGPUWork:Frame :: IORef [GPUWork]
$sel:fRenderFinishedHostSemaphore:Frame :: Semaphore
$sel:fPipelines:Frame :: p
$sel:fRenderpass:Frame :: rp
$sel:fSwapchainResources:Frame :: SwapchainResources
$sel:fMSAA:Frame :: SampleCountFlagBits
$sel:fPresent:Frame :: Maybe PresentModeKHR
fGPUWork :: IORef [GPUWork]
fResources :: (ReleaseKey, InternalState)
fRecycledResources :: RecycledResources rr
fRenderFinishedHostSemaphore :: Semaphore
fPipelines :: p
fRenderpass :: rp
fSwapchainResources :: SwapchainResources
fMSAA :: SampleCountFlagBits
fPresent :: Maybe PresentModeKHR
..
    }

pattern INFLIGHT_FRAMES :: (Eq a, Num a) => a
pattern $bINFLIGHT_FRAMES :: forall a. (Eq a, Num a) => a
$mINFLIGHT_FRAMES :: forall {r} {a}.
(Eq a, Num a) =>
a -> ((# #) -> r) -> ((# #) -> r) -> r
INFLIGHT_FRAMES = 2 -- XXX: up to two frames submitted for rendering

-- | Derive next frame
advance
  :: ( HasLogFunc env
     , HasVulkan env
     , MonadResource (RIO env)
     , RenderPass rp
     )
  => WaitResource (RecycledResources rr)
  -> Frame rp p rr
  -> Bool
  -> RIO env (Frame rp p rr)
advance :: forall env rp rr p.
(HasLogFunc env, HasVulkan env, MonadResource (RIO env),
 RenderPass rp) =>
WaitResource (RecycledResources rr)
-> Frame rp p rr -> Bool -> RIO env (Frame rp p rr)
advance WaitResource (RecycledResources rr)
waitDumped Frame rp p rr
f Bool
needsNewSwapchain = do
  -- Wait for a prior frame to finish, then we can steal it's resources!

  -- Handle mvar indefinite timeout exception here:
  -- https://github.com/expipiplus1/vulkan/issues/236
  RecycledResources rr
fRecycledResources <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO WaitResource (RecycledResources rr)
waitDumped forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left IO (RecycledResources rr)
block ->
        forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
15e6 (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (RecycledResources rr)
block) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe (RecycledResources rr)
Nothing -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords
              [ Text
"Timed out waiting for recycled resources."
              , Text
"A recycler thread is stuck on timeline semaphore or something."
              , Text
"Try running with --recycler-wait 15000 or a similar value."
              ]
            forall (m :: * -> *) a. MonadIO m => m a
exitFailure
          Just RecycledResources rr
rr ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure RecycledResources rr
rr
      Right RecycledResources rr
rs ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure RecycledResources rr
rs

  (SwapchainResources
fSwapchainResources, rp
fRenderpass) <- Frame rp p rr -> RIO env (SwapchainResources, rp)
getNext Frame rp p rr
f

  -- The per-frame resource helpers need to be created fresh
  IORef [GPUWork]
fGPUWork   <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Monoid a => a
mempty
  (ReleaseKey, InternalState)
fResources <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate forall (m :: * -> *). MonadIO m => m InternalState
ResourceT.createInternalState forall (m :: * -> *). MonadIO m => InternalState -> m ()
ResourceT.closeInternalState

  pure Frame
    { $sel:fIndex:Frame :: Word64
fIndex                       = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
fIndex Frame rp p rr
f forall a. Num a => a -> a -> a
+ Word64
1
    , $sel:fWindow:Frame :: Window
fWindow                      = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
fWindow Frame rp p rr
f
    , $sel:fSurface:Frame :: SurfaceKHR
fSurface                     = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SurfaceKHR
fSurface Frame rp p rr
f
    , $sel:fPipelines:Frame :: p
fPipelines                   = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> pipelines
fPipelines Frame rp p rr
f
    , $sel:fRenderFinishedHostSemaphore:Frame :: Semaphore
fRenderFinishedHostSemaphore = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Semaphore
fRenderFinishedHostSemaphore Frame rp p rr
f
    , $sel:fStageResources:Frame :: (RefCounted, InternalState)
fStageResources              = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
fStageResources Frame rp p rr
f
    , $sel:fPresent:Frame :: Maybe PresentModeKHR
fPresent                     = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Maybe PresentModeKHR
fPresent Frame rp p rr
f
    , $sel:fMSAA:Frame :: SampleCountFlagBits
fMSAA                        = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SampleCountFlagBits
fMSAA Frame rp p rr
f
    , SwapchainResources
fSwapchainResources :: SwapchainResources
$sel:fSwapchainResources:Frame :: SwapchainResources
fSwapchainResources
    , rp
fRenderpass :: rp
$sel:fRenderpass:Frame :: rp
fRenderpass
    , IORef [GPUWork]
fGPUWork :: IORef [GPUWork]
$sel:fGPUWork:Frame :: IORef [GPUWork]
fGPUWork
    , (ReleaseKey, InternalState)
fResources :: (ReleaseKey, InternalState)
$sel:fResources:Frame :: (ReleaseKey, InternalState)
fResources
    , RecycledResources rr
fRecycledResources :: RecycledResources rr
$sel:fRecycledResources:Frame :: RecycledResources rr
fRecycledResources
    }
  where
    getNext :: Frame rp p rr -> RIO env (SwapchainResources, rp)
getNext Frame{rp
p
Maybe PresentModeKHR
Word64
(ReleaseKey, InternalState)
(RefCounted, InternalState)
Window
IORef [GPUWork]
SurfaceKHR
Semaphore
SampleCountFlagBits
SwapchainResources
RecycledResources rr
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
$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: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:fStageResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
$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
..} = do
      if Bool
needsNewSwapchain then do
        Extent2D
windowSize <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Window -> IO Extent2D
Window.getExtent2D Window
fWindow
        SwapchainResources
newResources <- forall env.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
Maybe PresentModeKHR
-> SampleCountFlagBits
-> Extent2D
-> SwapchainResources
-> RIO env SwapchainResources
recreateSwapchainResources Maybe PresentModeKHR
fPresent SampleCountFlagBits
fMSAA Extent2D
windowSize SwapchainResources
fSwapchainResources

        let
          formatMatch :: Bool
formatMatch =
            SwapchainInfo -> Format
siSurfaceFormat (SwapchainResources -> SwapchainInfo
srInfo SwapchainResources
newResources) forall a. Eq a => a -> a -> Bool
==
            SwapchainInfo -> Format
siSurfaceFormat (SwapchainResources -> SwapchainInfo
srInfo SwapchainResources
fSwapchainResources)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
formatMatch do
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Swapchain changed format"
          forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"TODO: Handle swapchain changing formats"

        rp
newRenderpass <- forall a env swapchain.
(RenderPass a, HasLogFunc env, HasSwapchain swapchain,
 HasVulkan env, MonadResource (RIO env)) =>
swapchain -> a -> RIO env a
updateRenderpass SwapchainResources
newResources rp
fRenderpass

        pure
          ( SwapchainResources
newResources
          , rp
newRenderpass
          )
      else
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( SwapchainResources
fSwapchainResources
          , rp
fRenderpass
          )

run
  :: ( HasLogFunc env
     , HasVulkan env
     , MonadResource (RIO env)
     )
  => (RecycledResources rr -> IO ())
  -> Maybe Int
  -> RIO (env, Frame rp p rr) a
  -> Frame rp p rr
  -> RIO env a
run :: forall env rr rp p a.
(HasLogFunc env, HasVulkan env, MonadResource (RIO env)) =>
(RecycledResources rr -> IO ())
-> Maybe Int
-> RIO (env, Frame rp p rr) a
-> Frame rp p rr
-> RIO env a
run RecycledResources rr -> IO ()
recycle Maybe Int
recyclerWait RIO (env, Frame rp p rr) a
render frame :: Frame rp p rr
frame@Frame{rp
p
Maybe PresentModeKHR
Word64
(ReleaseKey, InternalState)
(RefCounted, InternalState)
Window
IORef [GPUWork]
SurfaceKHR
Semaphore
SampleCountFlagBits
SwapchainResources
RecycledResources rr
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
$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: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:fStageResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
$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
..} = do
  env
env <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (env
env, Frame rp p rr
frame) RIO (env, Frame rp p rr) a
render forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *) a.
(MonadUnliftIO m, MonadResource m) =>
m a -> m (Async a)
spawn RIO env ()
flush)
  where
    flush :: RIO env ()
flush = do
      Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
      [GPUWork]
waits <- forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef [GPUWork]
fGPUWork
      let tenSecondsKhr :: Word64
tenSecondsKhr = Word64
10e9
      -- logDebug $ "Waiting Frame " <> displayShow fIndex

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GPUWork]
waits) do
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Maybe Int
recyclerWait
        let
          waitInfo :: SemaphoreWaitInfo
waitInfo = forall a. Zero a => a
zero
            { $sel:semaphores:SemaphoreWaitInfo :: Vector Semaphore
Vk12.semaphores = forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [GPUWork]
waits)
            , $sel:values:SemaphoreWaitInfo :: Vector Word64
Vk12.values     = forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [GPUWork]
waits)
            }
        forall env (m :: * -> *).
(MonadVulkan env m, HasLogFunc env) =>
SemaphoreWaitInfo -> Word64 -> m Result
waitTwice SemaphoreWaitInfo
waitInfo Word64
tenSecondsKhr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Result
Vk.TIMEOUT -> do
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Time out (10s) waiting for frame to finish on Device"
            forall (m :: * -> *) a. MonadThrow m => String -> m a
timeoutError String
"Time out (10s) waiting for frame to finish on Device"
            {-
              XXX: recycler thread will crash now, never recycling its resources,
              resulting in an indefinite MVar block.
            -}
          Result
Vk.SUCCESS ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Result
huh ->
            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"waitTwice returned " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Result
huh

      -- logDebug $ "Flushing Frame " <> displayShow fIndex

      -- Free resources wanted elsewhere now, all those in RecycledResources
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. RecycledResources a -> Queues CommandPool
rrQueues RecycledResources rr
fRecycledResources) \CommandPool
commandPool ->
        forall (io :: * -> *).
MonadIO io =>
Device -> CommandPool -> CommandPoolResetFlags -> io ()
Vk.resetCommandPool Device
device CommandPool
commandPool CommandPoolResetFlags
Vk.COMMAND_POOL_RESET_RELEASE_RESOURCES_BIT

      -- Signal we're done by making the recycled resources available
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RecycledResources rr -> IO ()
recycle RecycledResources rr
fRecycledResources

      -- Destroy frame-specific resources at our leisure
      forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release (forall a b. (a, b) -> a
fst (ReleaseKey, InternalState)
fResources)

-- | 'queueSubmit' and add wait for the timeline 'Semaphore' before retiring the frame.
queueSubmit
  :: MonadVulkan env m
  => Vk.Queue
  -> Vector (SomeStruct Vk.SubmitInfo)
  -> IORef [GPUWork]
  -> Vk.Semaphore
  -> Word64
  -> m ()
queueSubmit :: forall env (m :: * -> *).
MonadVulkan env m =>
Queue
-> Vector (SomeStruct SubmitInfo)
-> IORef [GPUWork]
-> Semaphore
-> Word64
-> m ()
queueSubmit Queue
q Vector (SomeStruct SubmitInfo)
submits IORef [GPUWork]
gpuWork Semaphore
hostSemaphore Word64
frameIndex = do
  {-
    Make sure we don't get interrupted between submitting the work and
    recording the wait.
  -}
  forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
mask \forall a. m a -> m a
_ -> do
    forall (io :: * -> *).
MonadIO io =>
Queue -> Vector (SomeStruct SubmitInfo) -> Fence -> io ()
Vk.queueSubmit Queue
q Vector (SomeStruct SubmitInfo)
submits forall a. IsHandle a => a
Vk.NULL_HANDLE
    forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef [GPUWork]
gpuWork \[GPUWork]
waits ->
      ( (Semaphore
hostSemaphore, Word64
frameIndex) forall a. a -> [a] -> [a]
: [GPUWork]
waits
      , ()
      )

initialRecycledResources
  :: ( Resource.MonadResource (RIO env)
     , HasVulkan env
     , HasLogFunc env
     )
  => (Queues Vk.CommandPool -> rp -> p -> ResourceT (RIO env) rr)
  -> rp
  -> p
  -> ResourceT (RIO env) (RecycledResources rr)
initialRecycledResources :: forall env rp p rr.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
(Queues CommandPool -> rp -> p -> ResourceT (RIO env) rr)
-> rp -> p -> ResourceT (RIO env) (RecycledResources rr)
initialRecycledResources Queues CommandPool -> rp -> p -> ResourceT (RIO env) rr
initialRecycledData rp
rps p
pipes = do
  Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice

  (ReleaseKey
_iaKey, Semaphore
rrImageAvailableSemaphore) <- forall (a :: [*]) (io :: * -> *) r.
(Extendss SemaphoreCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> SemaphoreCreateInfo a
-> Maybe AllocationCallbacks
-> (io Semaphore -> (Semaphore -> io ()) -> r)
-> r
Vk.withSemaphore
    Device
device
    (forall a. Zero a => a
zero forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& SemaphoreType -> Word64 -> SemaphoreTypeCreateInfo
Vk12.SemaphoreTypeCreateInfo SemaphoreType
Vk12.SEMAPHORE_TYPE_BINARY Word64
0 forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ())
    forall a. Maybe a
Nothing
    forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate

  (ReleaseKey
_rfKey, Semaphore
rrRenderFinishedSemaphore) <- forall (a :: [*]) (io :: * -> *) r.
(Extendss SemaphoreCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> SemaphoreCreateInfo a
-> Maybe AllocationCallbacks
-> (io Semaphore -> (Semaphore -> io ()) -> r)
-> r
Vk.withSemaphore
    Device
device
    (forall a. Zero a => a
zero forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& SemaphoreType -> Word64 -> SemaphoreTypeCreateInfo
Vk12.SemaphoreTypeCreateInfo SemaphoreType
Vk12.SEMAPHORE_TYPE_BINARY Word64
0 forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ())
    forall a. Maybe a
Nothing
    forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate

  Queues (QueueFamilyIndex, Queue)
queues <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Queues (QueueFamilyIndex, Queue)
getQueues
  Queues CommandPool
rrQueues <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Queues (QueueFamilyIndex, Queue)
queues \(QueueFamilyIndex "image index" ::: Word32
ix, Queue
_queue) -> do
    let
      commandPoolCI :: CommandPoolCreateInfo
commandPoolCI = Vk.CommandPoolCreateInfo
        { $sel:flags:CommandPoolCreateInfo :: CommandPoolCreateFlags
flags            = forall a. Zero a => a
zero
        , $sel:queueFamilyIndex:CommandPoolCreateInfo :: "image index" ::: Word32
queueFamilyIndex = "image index" ::: Word32
ix
        }
    IO ()
cpDebug <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Release time for command pool for queue " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display "image index" ::: Word32
ix
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
ResourceT.register IO ()
cpDebug
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$! forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandPoolCreateInfo
-> Maybe AllocationCallbacks
-> (io CommandPool -> (CommandPool -> io ()) -> r)
-> r
Vk.withCommandPool Device
device CommandPoolCreateInfo
commandPoolCI forall a. Maybe a
Nothing forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
ResourceT.allocate

  rr
rrData <- Queues CommandPool -> rp -> p -> ResourceT (RIO env) rr
initialRecycledData Queues CommandPool
rrQueues rp
rps p
pipes

  pure RecycledResources{rr
Semaphore
Queues CommandPool
$sel:rrData:RecycledResources :: rr
$sel:rrRenderFinishedSemaphore:RecycledResources :: Semaphore
$sel:rrImageAvailableSemaphore:RecycledResources :: Semaphore
rrData :: rr
rrQueues :: Queues CommandPool
rrRenderFinishedSemaphore :: Semaphore
rrImageAvailableSemaphore :: Semaphore
$sel:rrQueues:RecycledResources :: Queues CommandPool
..}

{- |
  Wait for some semaphores, if the wait times out give the frame one last
  chance to complete with a zero timeout.

  It could be that the program was suspended during the preceding
  wait causing it to timeout, this will check if it actually
  finished.
-}
waitTwice
  :: (MonadVulkan env m, HasLogFunc env)
  => Vk12.SemaphoreWaitInfo
  -> "timeout" ::: Word64
  -> m Vk.Result
waitTwice :: forall env (m :: * -> *).
(MonadVulkan env m, HasLogFunc env) =>
SemaphoreWaitInfo -> Word64 -> m Result
waitTwice SemaphoreWaitInfo
waitInfo Word64
t = do
  Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
  forall (io :: * -> *).
MonadIO io =>
Device -> SemaphoreWaitInfo -> Word64 -> io Result
Vk12.waitSemaphoresSafe Device
device SemaphoreWaitInfo
waitInfo Word64
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Result
Vk.TIMEOUT -> do
      Result
r <- forall (io :: * -> *).
MonadIO io =>
Device -> SemaphoreWaitInfo -> Word64 -> io Result
Vk12.waitSemaphoresSafe Device
device SemaphoreWaitInfo
waitInfo Word64
1e3
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
        [ Utf8Builder
"waiting a second time on " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SemaphoreWaitInfo
waitInfo
        , Utf8Builder
" got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Result
r
        ]
      pure Result
r
    Result
r ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r

timeoutError :: MonadThrow m => String -> m a
timeoutError :: forall (m :: * -> *) a. MonadThrow m => String -> m a
timeoutError String
message =
  forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError forall a. Maybe a
Nothing IOErrorType
TimeExpired String
"" String
message forall a. Maybe a
Nothing forall a. Maybe a
Nothing

spawn :: (MonadUnliftIO m, MonadResource m) => m a -> m (Async a)
spawn :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadResource m) =>
m a -> m (Async a)
spawn m a
action = do
  IO a
actionIO <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO m a
action
  {-
    If we don't remove the release key when the thread is done it'll leak,
    remove it at the end of the async action when the thread is going to
    die anyway.

    Mask this so there's no chance we're inturrupted before writing the mvar.
  -}
  MVar ReleaseKey
kv  <- forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
  forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
_ -> do
    (ReleaseKey
k, Async a
r) <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
      (forall (m :: * -> *) a.
MonadUnliftIO m =>
((forall b. m b -> m b) -> m a) -> m (Async a)
asyncWithUnmask \forall b. IO b -> IO b
unmask ->
        forall b. IO b -> IO b
unmask forall a b. (a -> b) -> a -> b
$ IO a
actionIO forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (forall (m :: * -> *). MonadIO m => ReleaseKey -> m (Maybe (IO ()))
Resource.unprotect forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar ReleaseKey
kv))
      )
      forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel
    forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar ReleaseKey
kv ReleaseKey
k
    pure Async a
r