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

  GlobalHandles{Window
Allocator
Var Extent2D
StageSwitchVar
PhysicalDevice
Instance
Device
SurfaceKHR
PhysicalDeviceInfo
Queues (QueueFamilyIndex, Queue)
Options
ghOptions :: Options
ghWindow :: Window
ghSurface :: SurfaceKHR
ghInstance :: Instance
ghPhysicalDevice :: PhysicalDevice
ghPhysicalDeviceInfo :: PhysicalDeviceInfo
ghDevice :: Device
ghAllocator :: Allocator
ghQueues :: Queues (QueueFamilyIndex, Queue)
ghScreenVar :: Var Extent2D
ghStageSwitch :: StageSwitchVar
$sel:ghOptions:GlobalHandles :: GlobalHandles -> Options
$sel:ghWindow:GlobalHandles :: GlobalHandles -> Window
$sel:ghSurface:GlobalHandles :: GlobalHandles -> SurfaceKHR
$sel:ghInstance:GlobalHandles :: GlobalHandles -> Instance
$sel:ghPhysicalDevice:GlobalHandles :: GlobalHandles -> PhysicalDevice
$sel:ghPhysicalDeviceInfo:GlobalHandles :: GlobalHandles -> PhysicalDeviceInfo
$sel:ghDevice:GlobalHandles :: GlobalHandles -> Device
$sel:ghAllocator:GlobalHandles :: GlobalHandles -> Allocator
$sel:ghQueues:GlobalHandles :: GlobalHandles -> Queues (QueueFamilyIndex, Queue)
$sel:ghScreenVar:GlobalHandles :: GlobalHandles -> Var Extent2D
$sel:ghStageSwitch:GlobalHandles :: GlobalHandles -> StageSwitchVar
..} <- (App GlobalHandles st -> GlobalHandles)
-> RIO (App GlobalHandles st) GlobalHandles
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks App GlobalHandles st -> GlobalHandles
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 <- IO Extent2D -> RIO (App GlobalHandles st) Extent2D
forall a. IO a -> RIO (App GlobalHandles st) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Extent2D -> RIO (App GlobalHandles st) Extent2D)
-> IO Extent2D -> RIO (App GlobalHandles st) Extent2D
forall a b. (a -> b) -> a -> b
$ Window -> IO Extent2D
Window.getExtent2D Window
ghWindow
      let oldSwapchain :: SwapchainKHR
oldSwapchain = SwapchainKHR
forall a. IsHandle a => a
Vk.NULL_HANDLE
      Maybe PresentModeKHR
-> SampleCountFlagBits
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> Var Extent2D
-> RIO (App GlobalHandles st) SwapchainResources
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 ->
      SwapchainResources -> RIO (App GlobalHandles st) SwapchainResources
forall a. a -> RIO (App GlobalHandles st) a
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) <- IO InternalState
-> (InternalState -> IO ())
-> RIO (App GlobalHandles st) (ReleaseKey, InternalState)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate IO InternalState
forall (m :: * -> *). MonadIO m => m InternalState
ResourceT.createInternalState InternalState -> IO ()
forall (m :: * -> *). MonadIO m => InternalState -> m ()
ResourceT.closeInternalState
  RefCounted
stageRefCounted <- IO () -> RIO (App GlobalHandles st) RefCounted
forall (m :: * -> *). MonadIO m => IO () -> m RefCounted
newRefCounted (IO () -> RIO (App GlobalHandles st) RefCounted)
-> IO () -> RIO (App GlobalHandles st) RefCounted
forall a b. (a -> b) -> a -> b
$ ReleaseKey -> IO ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
stageKey
  (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
semiFrame <- (ResourceT
   (RIO (App GlobalHandles st))
   (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
 -> InternalState
 -> RIO
      (App GlobalHandles st)
      (SwapchainResources, rp, p, Semaphore, RecycledResources rr))
-> InternalState
-> ResourceT
     (RIO (App GlobalHandles st))
     (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
-> RIO
     (App GlobalHandles st)
     (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ResourceT
  (RIO (App GlobalHandles st))
  (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
-> InternalState
-> RIO
     (App GlobalHandles st)
     (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
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 <- ResourceT (RIO (App GlobalHandles st)) ()
-> ResourceT (RIO (App GlobalHandles st)) (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (ResourceT (RIO (App GlobalHandles st)) ()
 -> ResourceT (RIO (App GlobalHandles st)) (IO ()))
-> (Utf8Builder -> ResourceT (RIO (App GlobalHandles st)) ())
-> Utf8Builder
-> ResourceT (RIO (App GlobalHandles st)) (IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> ResourceT (RIO (App GlobalHandles st)) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> ResourceT (RIO (App GlobalHandles st)) (IO ()))
-> Utf8Builder -> ResourceT (RIO (App GlobalHandles st)) (IO ())
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Allocating inside stage " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
sTitle
    IO ()
debugRelease <- ResourceT (RIO (App GlobalHandles st)) ()
-> ResourceT (RIO (App GlobalHandles st)) (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (ResourceT (RIO (App GlobalHandles st)) ()
 -> ResourceT (RIO (App GlobalHandles st)) (IO ()))
-> (Utf8Builder -> ResourceT (RIO (App GlobalHandles st)) ())
-> Utf8Builder
-> ResourceT (RIO (App GlobalHandles st)) (IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> ResourceT (RIO (App GlobalHandles st)) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> ResourceT (RIO (App GlobalHandles st)) (IO ()))
-> Utf8Builder -> ResourceT (RIO (App GlobalHandles st)) (IO ())
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Releasing inside stage " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
sTitle
    ResourceT (RIO (App GlobalHandles st)) ReleaseKey
-> ResourceT (RIO (App GlobalHandles st)) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT (RIO (App GlobalHandles st)) ReleaseKey
 -> ResourceT (RIO (App GlobalHandles st)) ())
-> ResourceT (RIO (App GlobalHandles st)) ReleaseKey
-> ResourceT (RIO (App GlobalHandles st)) ()
forall a b. (a -> b) -> a -> b
$! IO () -> IO () -> ResourceT (RIO (App GlobalHandles st)) ReleaseKey
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) <- Device
-> SemaphoreCreateInfo '[SemaphoreTypeCreateInfo]
-> Maybe AllocationCallbacks
-> (IO Semaphore
    -> (Semaphore -> IO ())
    -> ResourceT (RIO (App GlobalHandles st)) (ReleaseKey, Semaphore))
-> ResourceT (RIO (App GlobalHandles st)) (ReleaseKey, Semaphore)
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
      (SemaphoreCreateInfo '[]
forall a. Zero a => a
zero SemaphoreCreateInfo '[]
-> Chain '[SemaphoreTypeCreateInfo]
-> SemaphoreCreateInfo '[SemaphoreTypeCreateInfo]
forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& SemaphoreType -> Word64 -> SemaphoreTypeCreateInfo
Vk12.SemaphoreTypeCreateInfo SemaphoreType
Vk12.SEMAPHORE_TYPE_TIMELINE Word64
0 SemaphoreTypeCreateInfo
-> Chain '[] -> Chain '[SemaphoreTypeCreateInfo]
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ())
      Maybe AllocationCallbacks
forall a. Maybe a
Nothing
      IO Semaphore
-> (Semaphore -> IO ())
-> ResourceT (RIO (App GlobalHandles st)) (ReleaseKey, Semaphore)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate

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

    IO ()
releaseDataDebug <- ResourceT (RIO (App GlobalHandles st)) ()
-> ResourceT (RIO (App GlobalHandles st)) (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (ResourceT (RIO (App GlobalHandles st)) ()
 -> ResourceT (RIO (App GlobalHandles st)) (IO ()))
-> (Utf8Builder -> ResourceT (RIO (App GlobalHandles st)) ())
-> Utf8Builder
-> ResourceT (RIO (App GlobalHandles st)) (IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> ResourceT (RIO (App GlobalHandles st)) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> ResourceT (RIO (App GlobalHandles st)) (IO ()))
-> Utf8Builder -> ResourceT (RIO (App GlobalHandles st)) (IO ())
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Releasing recycled resources for stage " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
sTitle
    ResourceT (RIO (App GlobalHandles st)) ReleaseKey
-> ResourceT (RIO (App GlobalHandles st)) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT (RIO (App GlobalHandles st)) ReleaseKey
 -> ResourceT (RIO (App GlobalHandles st)) ())
-> ResourceT (RIO (App GlobalHandles st)) ReleaseKey
-> ResourceT (RIO (App GlobalHandles st)) ()
forall a b. (a -> b) -> a -> b
$! IO () -> ResourceT (RIO (App GlobalHandles st)) ReleaseKey
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 <- IO InternalState
-> (InternalState -> IO ())
-> RIO (App GlobalHandles st) (ReleaseKey, InternalState)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate IO InternalState
forall (m :: * -> *). MonadIO m => m InternalState
ResourceT.createInternalState InternalState -> IO ()
forall (m :: * -> *). MonadIO m => InternalState -> m ()
ResourceT.closeInternalState

  IORef [GPUWork]
fGPUWork <- IO (IORef [GPUWork])
-> RIO (App GlobalHandles st) (IORef [GPUWork])
forall a. IO a -> RIO (App GlobalHandles st) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [GPUWork])
 -> RIO (App GlobalHandles st) (IORef [GPUWork]))
-> IO (IORef [GPUWork])
-> RIO (App GlobalHandles st) (IORef [GPUWork])
forall a b. (a -> b) -> a -> b
$ [GPUWork] -> IO (IORef [GPUWork])
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef [GPUWork]
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]
SampleCountFlagBits
Semaphore
SwapchainResources
RecycledResources rr
fPresent :: Maybe PresentModeKHR
fMSAA :: SampleCountFlagBits
fSwapchainResources :: SwapchainResources
fRenderpass :: rp
fPipelines :: p
fRenderFinishedHostSemaphore :: Semaphore
fRecycledResources :: RecycledResources rr
fResources :: (ReleaseKey, InternalState)
fGPUWork :: IORef [GPUWork]
$sel:fPresent:Frame :: Maybe PresentModeKHR
$sel:fMSAA:Frame :: SampleCountFlagBits
$sel:fSwapchainResources:Frame :: SwapchainResources
$sel:fRenderpass:Frame :: rp
$sel:fPipelines:Frame :: p
$sel:fRenderFinishedHostSemaphore:Frame :: Semaphore
$sel:fGPUWork:Frame :: IORef [GPUWork]
$sel:fResources:Frame :: (ReleaseKey, InternalState)
$sel:fRecycledResources:Frame :: RecycledResources rr
..
    }

pattern INFLIGHT_FRAMES :: (Eq a, Num a) => a
pattern $mINFLIGHT_FRAMES :: forall {r} {a}.
(Eq a, Num a) =>
a -> ((# #) -> r) -> ((# #) -> r) -> r
$bINFLIGHT_FRAMES :: forall a. (Eq a, Num a) => a
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 <-
    WaitResource (RecycledResources rr)
-> RIO
     env (Either (IO (RecycledResources rr)) (RecycledResources rr))
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO WaitResource (RecycledResources rr)
waitDumped RIO env (Either (IO (RecycledResources rr)) (RecycledResources rr))
-> (Either (IO (RecycledResources rr)) (RecycledResources rr)
    -> RIO env (RecycledResources rr))
-> RIO env (RecycledResources rr)
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left IO (RecycledResources rr)
block ->
        Int
-> RIO env (RecycledResources rr)
-> RIO env (Maybe (RecycledResources rr))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
15e6 (IO (RecycledResources rr) -> RIO env (RecycledResources rr)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (RecycledResources rr)
block) RIO env (Maybe (RecycledResources rr))
-> (Maybe (RecycledResources rr) -> RIO env (RecycledResources rr))
-> RIO env (RecycledResources rr)
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe (RecycledResources rr)
Nothing -> do
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ())
-> (Text -> Utf8Builder) -> Text -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> RIO env ()) -> Text -> RIO env ()
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."
              ]
            RIO env (RecycledResources rr)
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
          Just RecycledResources rr
rr ->
            RecycledResources rr -> RIO env (RecycledResources rr)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecycledResources rr
rr
      Right RecycledResources rr
rs ->
        RecycledResources rr -> RIO env (RecycledResources rr)
forall a. a -> RIO env a
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   <- IO (IORef [GPUWork]) -> RIO env (IORef [GPUWork])
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [GPUWork]) -> RIO env (IORef [GPUWork]))
-> IO (IORef [GPUWork]) -> RIO env (IORef [GPUWork])
forall a b. (a -> b) -> a -> b
$ [GPUWork] -> IO (IORef [GPUWork])
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef [GPUWork]
forall a. Monoid a => a
mempty
  (ReleaseKey, InternalState)
fResources <- IO InternalState
-> (InternalState -> IO ()) -> RIO env (ReleaseKey, InternalState)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate IO InternalState
forall (m :: * -> *). MonadIO m => m InternalState
ResourceT.createInternalState InternalState -> IO ()
forall (m :: * -> *). MonadIO m => InternalState -> m ()
ResourceT.closeInternalState

  pure Frame
    { $sel:fIndex:Frame :: Word64
fIndex                       = Frame rp p rr -> Word64
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
fIndex Frame rp p rr
f Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
    , $sel:fWindow:Frame :: Window
fWindow                      = Frame rp p rr -> Window
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
fWindow Frame rp p rr
f
    , $sel:fSurface:Frame :: SurfaceKHR
fSurface                     = Frame rp p rr -> SurfaceKHR
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SurfaceKHR
fSurface Frame rp p rr
f
    , $sel:fPipelines:Frame :: p
fPipelines                   = Frame rp p rr -> p
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> pipelines
fPipelines Frame rp p rr
f
    , $sel:fRenderFinishedHostSemaphore:Frame :: Semaphore
fRenderFinishedHostSemaphore = Frame rp p rr -> Semaphore
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Semaphore
fRenderFinishedHostSemaphore Frame rp p rr
f
    , $sel:fStageResources:Frame :: (RefCounted, InternalState)
fStageResources              = Frame rp p rr -> (RefCounted, InternalState)
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
fStageResources Frame rp p rr
f
    , $sel:fPresent:Frame :: Maybe PresentModeKHR
fPresent                     = Frame rp p rr -> Maybe PresentModeKHR
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Maybe PresentModeKHR
fPresent Frame rp p rr
f
    , $sel:fMSAA:Frame :: SampleCountFlagBits
fMSAA                        = Frame rp p rr -> SampleCountFlagBits
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SampleCountFlagBits
fMSAA Frame rp p rr
f
    , SwapchainResources
$sel:fSwapchainResources:Frame :: SwapchainResources
fSwapchainResources :: SwapchainResources
fSwapchainResources
    , rp
$sel:fRenderpass:Frame :: rp
fRenderpass :: rp
fRenderpass
    , IORef [GPUWork]
$sel:fGPUWork:Frame :: IORef [GPUWork]
fGPUWork :: IORef [GPUWork]
fGPUWork
    , (ReleaseKey, InternalState)
$sel:fResources:Frame :: (ReleaseKey, InternalState)
fResources :: (ReleaseKey, InternalState)
fResources
    , RecycledResources rr
$sel:fRecycledResources:Frame :: RecycledResources rr
fRecycledResources :: 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]
SampleCountFlagBits
Semaphore
SurfaceKHR
SwapchainResources
RecycledResources rr
$sel:fIndex:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
$sel:fWindow:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
$sel:fSurface:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SurfaceKHR
$sel:fStageResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
$sel:fPresent:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Maybe PresentModeKHR
$sel:fMSAA:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SampleCountFlagBits
$sel:fSwapchainResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
$sel:fRenderpass:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> renderpass
$sel:fPipelines:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> pipelines
$sel:fRenderFinishedHostSemaphore:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Semaphore
$sel:fGPUWork:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> IORef [GPUWork]
$sel:fResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (ReleaseKey, InternalState)
$sel:fRecycledResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> RecycledResources resources
fIndex :: Word64
fWindow :: Window
fSurface :: SurfaceKHR
fPresent :: Maybe PresentModeKHR
fMSAA :: SampleCountFlagBits
fSwapchainResources :: SwapchainResources
fRenderpass :: rp
fPipelines :: p
fRenderFinishedHostSemaphore :: Semaphore
fStageResources :: (RefCounted, InternalState)
fGPUWork :: IORef [GPUWork]
fResources :: (ReleaseKey, InternalState)
fRecycledResources :: RecycledResources rr
..} = do
      if Bool
needsNewSwapchain then do
        Extent2D
windowSize <- IO Extent2D -> RIO env Extent2D
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Extent2D -> RIO env Extent2D)
-> IO Extent2D -> RIO env Extent2D
forall a b. (a -> b) -> a -> b
$ Window -> IO Extent2D
Window.getExtent2D Window
fWindow
        SwapchainResources
newResources <- Maybe PresentModeKHR
-> SampleCountFlagBits
-> Extent2D
-> SwapchainResources
-> RIO env SwapchainResources
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) Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
==
            SwapchainInfo -> Format
siSurfaceFormat (SwapchainResources -> SwapchainInfo
srInfo SwapchainResources
fSwapchainResources)
        Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
formatMatch do
          Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Swapchain changed format"
          String -> RIO env ()
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"TODO: Handle swapchain changing formats"

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

        pure
          ( SwapchainResources
newResources
          , rp
newRenderpass
          )
      else
        (SwapchainResources, rp) -> RIO env (SwapchainResources, rp)
forall a. a -> RIO env a
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]
SampleCountFlagBits
Semaphore
SurfaceKHR
SwapchainResources
RecycledResources rr
$sel:fIndex:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
$sel:fWindow:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
$sel:fSurface:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SurfaceKHR
$sel:fStageResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
$sel:fPresent:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Maybe PresentModeKHR
$sel:fMSAA:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SampleCountFlagBits
$sel:fSwapchainResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
$sel:fRenderpass:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> renderpass
$sel:fPipelines:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> pipelines
$sel:fRenderFinishedHostSemaphore:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Semaphore
$sel:fGPUWork:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> IORef [GPUWork]
$sel:fResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (ReleaseKey, InternalState)
$sel:fRecycledResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> RecycledResources resources
fIndex :: Word64
fWindow :: Window
fSurface :: SurfaceKHR
fPresent :: Maybe PresentModeKHR
fMSAA :: SampleCountFlagBits
fSwapchainResources :: SwapchainResources
fRenderpass :: rp
fPipelines :: p
fRenderFinishedHostSemaphore :: Semaphore
fStageResources :: (RefCounted, InternalState)
fGPUWork :: IORef [GPUWork]
fResources :: (ReleaseKey, InternalState)
fRecycledResources :: RecycledResources rr
..} = do
  env
env <- RIO env env
forall r (m :: * -> *). MonadReader r m => m r
ask
  (env, Frame rp p rr) -> RIO (env, Frame rp p rr) a -> RIO env a
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 RIO env a -> RIO env () -> RIO env a
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` RIO env (Async ()) -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env () -> RIO env (Async ())
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadResource m) =>
m a -> m (Async a)
spawn RIO env ()
flush)
  where
    flush :: RIO env ()
flush = do
      Device
device <- (env -> Device) -> RIO env Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice
      [GPUWork]
waits <- IORef [GPUWork] -> RIO env [GPUWork]
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef [GPUWork]
fGPUWork
      let tenSecondsKhr :: Word64
tenSecondsKhr = Word64
10e9
      -- logDebug $ "Waiting Frame " <> displayShow fIndex

      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GPUWork] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GPUWork]
waits) do
        (Int -> RIO env ()) -> Maybe Int -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Int -> RIO env ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Maybe Int
recyclerWait
        let
          waitInfo :: SemaphoreWaitInfo
waitInfo = SemaphoreWaitInfo
forall a. Zero a => a
zero
            { $sel:semaphores:SemaphoreWaitInfo :: Vector Semaphore
Vk12.semaphores = [Semaphore] -> Vector Semaphore
forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList ((GPUWork -> Semaphore) -> [GPUWork] -> [Semaphore]
forall a b. (a -> b) -> [a] -> [b]
map GPUWork -> Semaphore
forall a b. (a, b) -> a
fst [GPUWork]
waits)
            , $sel:values:SemaphoreWaitInfo :: Vector Word64
Vk12.values     = [Word64] -> Vector Word64
forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList ((GPUWork -> Word64) -> [GPUWork] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map GPUWork -> Word64
forall a b. (a, b) -> b
snd [GPUWork]
waits)
            }
        SemaphoreWaitInfo -> Word64 -> RIO env Result
forall env (m :: * -> *).
(MonadVulkan env m, HasLogFunc env) =>
SemaphoreWaitInfo -> Word64 -> m Result
waitTwice SemaphoreWaitInfo
waitInfo Word64
tenSecondsKhr RIO env Result -> (Result -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Result
Vk.TIMEOUT -> do
            Utf8Builder -> RIO env ()
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"
            String -> RIO env ()
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 ->
            () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Result
huh ->
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"waitTwice returned " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Result -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Result
huh

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

      -- Free resources wanted elsewhere now, all those in RecycledResources
      Queues CommandPool -> (CommandPool -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (RecycledResources rr -> Queues CommandPool
forall a. RecycledResources a -> Queues CommandPool
rrQueues RecycledResources rr
fRecycledResources) \CommandPool
commandPool ->
        Device -> CommandPool -> CommandPoolResetFlags -> RIO env ()
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
      IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ RecycledResources rr -> IO ()
recycle RecycledResources rr
fRecycledResources

      -- Destroy frame-specific resources at our leisure
      ReleaseKey -> RIO env ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ((ReleaseKey, InternalState) -> ReleaseKey
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 a. m a -> m a) -> m ()) -> m ()
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
mask \forall a. m a -> m a
_ -> do
    Queue -> Vector (SomeStruct SubmitInfo) -> Fence -> m ()
forall (io :: * -> *).
MonadIO io =>
Queue -> Vector (SomeStruct SubmitInfo) -> Fence -> io ()
Vk.queueSubmit Queue
q Vector (SomeStruct SubmitInfo)
submits Fence
forall a. IsHandle a => a
Vk.NULL_HANDLE
    IORef [GPUWork] -> ([GPUWork] -> ([GPUWork], ())) -> m ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef [GPUWork]
gpuWork \[GPUWork]
waits ->
      ( (Semaphore
hostSemaphore, Word64
frameIndex) GPUWork -> [GPUWork] -> [GPUWork]
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 <- (env -> Device) -> ResourceT (RIO env) Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice

  (ReleaseKey
_iaKey, Semaphore
rrImageAvailableSemaphore) <- Device
-> SemaphoreCreateInfo '[SemaphoreTypeCreateInfo]
-> Maybe AllocationCallbacks
-> (IO Semaphore
    -> (Semaphore -> IO ())
    -> ResourceT (RIO env) (ReleaseKey, Semaphore))
-> ResourceT (RIO env) (ReleaseKey, Semaphore)
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
    (SemaphoreCreateInfo '[]
forall a. Zero a => a
zero SemaphoreCreateInfo '[]
-> Chain '[SemaphoreTypeCreateInfo]
-> SemaphoreCreateInfo '[SemaphoreTypeCreateInfo]
forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& SemaphoreType -> Word64 -> SemaphoreTypeCreateInfo
Vk12.SemaphoreTypeCreateInfo SemaphoreType
Vk12.SEMAPHORE_TYPE_BINARY Word64
0 SemaphoreTypeCreateInfo
-> Chain '[] -> Chain '[SemaphoreTypeCreateInfo]
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ())
    Maybe AllocationCallbacks
forall a. Maybe a
Nothing
    IO Semaphore
-> (Semaphore -> IO ())
-> ResourceT (RIO env) (ReleaseKey, Semaphore)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate

  (ReleaseKey
_rfKey, Semaphore
rrRenderFinishedSemaphore) <- Device
-> SemaphoreCreateInfo '[SemaphoreTypeCreateInfo]
-> Maybe AllocationCallbacks
-> (IO Semaphore
    -> (Semaphore -> IO ())
    -> ResourceT (RIO env) (ReleaseKey, Semaphore))
-> ResourceT (RIO env) (ReleaseKey, Semaphore)
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
    (SemaphoreCreateInfo '[]
forall a. Zero a => a
zero SemaphoreCreateInfo '[]
-> Chain '[SemaphoreTypeCreateInfo]
-> SemaphoreCreateInfo '[SemaphoreTypeCreateInfo]
forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& SemaphoreType -> Word64 -> SemaphoreTypeCreateInfo
Vk12.SemaphoreTypeCreateInfo SemaphoreType
Vk12.SEMAPHORE_TYPE_BINARY Word64
0 SemaphoreTypeCreateInfo
-> Chain '[] -> Chain '[SemaphoreTypeCreateInfo]
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ())
    Maybe AllocationCallbacks
forall a. Maybe a
Nothing
    IO Semaphore
-> (Semaphore -> IO ())
-> ResourceT (RIO env) (ReleaseKey, Semaphore)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate

  Queues (QueueFamilyIndex, Queue)
queues <- (env -> Queues (QueueFamilyIndex, Queue))
-> ResourceT (RIO env) (Queues (QueueFamilyIndex, Queue))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Queues (QueueFamilyIndex, Queue)
forall a. HasVulkan a => a -> Queues (QueueFamilyIndex, Queue)
getQueues
  Queues CommandPool
rrQueues <- Queues (QueueFamilyIndex, Queue)
-> ((QueueFamilyIndex, Queue) -> ResourceT (RIO env) CommandPool)
-> ResourceT (RIO env) (Queues CommandPool)
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            = CommandPoolCreateFlags
forall a. Zero a => a
zero
        , $sel:queueFamilyIndex:CommandPoolCreateInfo :: "image index" ::: Word32
queueFamilyIndex = "image index" ::: Word32
ix
        }
    IO ()
cpDebug <- ResourceT (RIO env) () -> ResourceT (RIO env) (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (ResourceT (RIO env) () -> ResourceT (RIO env) (IO ()))
-> (Utf8Builder -> ResourceT (RIO env) ())
-> Utf8Builder
-> ResourceT (RIO env) (IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> ResourceT (RIO env) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> ResourceT (RIO env) (IO ()))
-> Utf8Builder -> ResourceT (RIO env) (IO ())
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Release time for command pool for queue " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ("image index" ::: Word32) -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display "image index" ::: Word32
ix
    ResourceT (RIO env) ReleaseKey -> ResourceT (RIO env) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT (RIO env) ReleaseKey -> ResourceT (RIO env) ())
-> ResourceT (RIO env) ReleaseKey -> ResourceT (RIO env) ()
forall a b. (a -> b) -> a -> b
$! IO () -> ResourceT (RIO env) ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
ResourceT.register IO ()
cpDebug
    ((ReleaseKey, CommandPool) -> CommandPool)
-> ResourceT (RIO env) (ReleaseKey, CommandPool)
-> ResourceT (RIO env) CommandPool
forall a b.
(a -> b) -> ResourceT (RIO env) a -> ResourceT (RIO env) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReleaseKey, CommandPool) -> CommandPool
forall a b. (a, b) -> b
snd (ResourceT (RIO env) (ReleaseKey, CommandPool)
 -> ResourceT (RIO env) CommandPool)
-> ResourceT (RIO env) (ReleaseKey, CommandPool)
-> ResourceT (RIO env) CommandPool
forall a b. (a -> b) -> a -> b
$! Device
-> CommandPoolCreateInfo
-> Maybe AllocationCallbacks
-> (IO CommandPool
    -> (CommandPool -> IO ())
    -> ResourceT (RIO env) (ReleaseKey, CommandPool))
-> ResourceT (RIO env) (ReleaseKey, CommandPool)
forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandPoolCreateInfo
-> Maybe AllocationCallbacks
-> (io CommandPool -> (CommandPool -> io ()) -> r)
-> r
Vk.withCommandPool Device
device CommandPoolCreateInfo
commandPoolCI Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO CommandPool
-> (CommandPool -> IO ())
-> ResourceT (RIO env) (ReleaseKey, CommandPool)
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:rrQueues:RecycledResources :: Queues CommandPool
rrImageAvailableSemaphore :: Semaphore
rrRenderFinishedSemaphore :: Semaphore
rrQueues :: Queues CommandPool
rrData :: rr
$sel:rrImageAvailableSemaphore:RecycledResources :: Semaphore
$sel:rrRenderFinishedSemaphore:RecycledResources :: Semaphore
$sel:rrData:RecycledResources :: rr
..}

{- |
  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 <- (env -> Device) -> m Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice
  Device -> SemaphoreWaitInfo -> Word64 -> m Result
forall (io :: * -> *).
MonadIO io =>
Device -> SemaphoreWaitInfo -> Word64 -> io Result
Vk12.waitSemaphoresSafe Device
device SemaphoreWaitInfo
waitInfo Word64
t m Result -> (Result -> m Result) -> m Result
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Result
Vk.TIMEOUT -> do
      Result
r <- Device -> SemaphoreWaitInfo -> Word64 -> m Result
forall (io :: * -> *).
MonadIO io =>
Device -> SemaphoreWaitInfo -> Word64 -> io Result
Vk12.waitSemaphoresSafe Device
device SemaphoreWaitInfo
waitInfo Word64
1e3
      Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
        [ Utf8Builder
"waiting a second time on " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> SemaphoreWaitInfo -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow SemaphoreWaitInfo
waitInfo
        , Utf8Builder
" got " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Result -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Result
r
        ]
      pure Result
r
    Result
r ->
      Result -> m Result
forall a. a -> m a
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 =
  IOException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (IOException -> m a) -> IOException -> m a
forall a b. (a -> b) -> a -> b
$ Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
TimeExpired String
"" String
message Maybe CInt
forall a. Maybe a
Nothing Maybe String
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 <- m a -> m (IO a)
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  <- m (MVar ReleaseKey)
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
  ((forall a. m a -> m a) -> m (Async a)) -> m (Async a)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m (Async a)) -> m (Async a))
-> ((forall a. m a -> m a) -> m (Async a)) -> m (Async a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
_ -> do
    (ReleaseKey
k, Async a
r) <- IO (Async a) -> (Async a -> IO ()) -> m (ReleaseKey, Async a)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
      (((forall b. IO b -> IO b) -> IO a) -> IO (Async a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
((forall b. m b -> m b) -> m a) -> m (Async a)
asyncWithUnmask \forall b. IO b -> IO b
unmask ->
        IO a -> IO a
forall b. IO b -> IO b
unmask (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a
actionIO IO a -> IO (Maybe (IO ())) -> IO a
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (ReleaseKey -> IO (Maybe (IO ()))
forall (m :: * -> *). MonadIO m => ReleaseKey -> m (Maybe (IO ()))
Resource.unprotect (ReleaseKey -> IO (Maybe (IO ())))
-> IO ReleaseKey -> IO (Maybe (IO ()))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ReleaseKey -> IO ReleaseKey
forall b. IO b -> IO b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar ReleaseKey -> IO ReleaseKey
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar ReleaseKey
kv))
      )
      Async a -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel
    MVar ReleaseKey -> ReleaseKey -> m ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar ReleaseKey
kv ReleaseKey
k
    pure Async a
r