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.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.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 :: 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 (StageRIO st) rr
SwapchainResources -> ResourceT (StageRIO st) rp
SwapchainResources -> rp -> ResourceT (StageRIO 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 (StageRIO st) rr
sInitialRS :: StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
sAllocateP :: SwapchainResources -> rp -> ResourceT (StageRIO st) p
sAllocateRP :: SwapchainResources -> ResourceT (StageRIO st) rp
sTitle :: Text
..} = do
  Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Making initial frame"

  GlobalHandles{StageSwitchVar
Window
Device
Instance
PhysicalDevice
SurfaceKHR
Allocator
PhysicalDeviceInfo
Queues (QueueFamilyIndex, Queue)
ProjectionProcess
$sel:ghStageSwitch:GlobalHandles :: GlobalHandles -> StageSwitchVar
$sel:ghScreenP:GlobalHandles :: GlobalHandles -> ProjectionProcess
$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
ghStageSwitch :: StageSwitchVar
ghScreenP :: ProjectionProcess
ghQueues :: Queues (QueueFamilyIndex, Queue)
ghAllocator :: Allocator
ghDevice :: Device
ghPhysicalDeviceInfo :: PhysicalDeviceInfo
ghPhysicalDevice :: PhysicalDevice
ghInstance :: Instance
ghSurface :: SurfaceKHR
ghWindow :: Window
..} <- (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

  SwapchainResources
sfSwapchainResources <- case Maybe SwapchainResources
oldSR of
    Maybe SwapchainResources
Nothing -> do
      Extent2D
windowSize <- IO Extent2D -> RIO (App GlobalHandles st) Extent2D
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
      SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> ProjectionProcess
-> RIO (App GlobalHandles st) SwapchainResources
forall env.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> ProjectionProcess
-> RIO env SwapchainResources
allocSwapchainResources
        SwapchainKHR
oldSwapchain
        Extent2D
windowSize
        SurfaceKHR
ghSurface
        ProjectionProcess
ghScreenP
    Just SwapchainResources
old ->
      SwapchainResources -> RIO (App GlobalHandles st) SwapchainResources
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
   (StageRIO st)
   (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
 -> InternalState
 -> StageRIO
      st (SwapchainResources, rp, p, Semaphore, RecycledResources rr))
-> InternalState
-> ResourceT
     (StageRIO st)
     (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
-> StageRIO
     st (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ResourceT
  (StageRIO st)
  (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
-> InternalState
-> StageRIO
     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 (StageRIO st) () -> ResourceT (StageRIO st) (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (ResourceT (StageRIO st) () -> ResourceT (StageRIO st) (IO ()))
-> (Utf8Builder -> ResourceT (StageRIO st) ())
-> Utf8Builder
-> ResourceT (StageRIO st) (IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> ResourceT (StageRIO st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> ResourceT (StageRIO st) (IO ()))
-> Utf8Builder -> ResourceT (StageRIO 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 (StageRIO st) () -> ResourceT (StageRIO st) (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (ResourceT (StageRIO st) () -> ResourceT (StageRIO st) (IO ()))
-> (Utf8Builder -> ResourceT (StageRIO st) ())
-> Utf8Builder
-> ResourceT (StageRIO st) (IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> ResourceT (StageRIO st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> ResourceT (StageRIO st) (IO ()))
-> Utf8Builder -> ResourceT (StageRIO 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 (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ())
-> ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ()
forall a b. (a -> b) -> a -> b
$! IO () -> IO () -> ResourceT (StageRIO 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 (StageRIO st) rp
sAllocateRP SwapchainResources
sfSwapchainResources

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

    (ReleaseKey
_, Semaphore
sfRenderFinishedHostSemaphore) <- Device
-> SemaphoreCreateInfo '[SemaphoreTypeCreateInfo]
-> Maybe AllocationCallbacks
-> (IO Semaphore
    -> (Semaphore -> IO ())
    -> ResourceT (StageRIO st) (ReleaseKey, Semaphore))
-> ResourceT (StageRIO 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 (StageRIO st) (ReleaseKey, Semaphore)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate

    Utf8Builder -> ResourceT (StageRIO st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> ResourceT (StageRIO st) ())
-> Utf8Builder -> ResourceT (StageRIO 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 (StageRIO st) rr)
-> rp -> p -> ResourceT (StageRIO 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 (StageRIO st) rr
sInitialRR rp
sfRenderpass p
sfPipelines
    Int -> ResourceT (StageRIO st) () -> ResourceT (StageRIO 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 (StageRIO st) rr)
-> rp -> p -> ResourceT (StageRIO 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 (StageRIO st) rr
sInitialRR rp
sfRenderpass p
sfPipelines
      IO () -> ResourceT (StageRIO st) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT (StageRIO st) ())
-> IO () -> ResourceT (StageRIO st) ()
forall a b. (a -> b) -> a -> b
$ DumpResource (RecycledResources rr)
dumpResource RecycledResources rr
resources

    IO ()
releaseDataDebug <- ResourceT (StageRIO st) () -> ResourceT (StageRIO st) (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (ResourceT (StageRIO st) () -> ResourceT (StageRIO st) (IO ()))
-> (Utf8Builder -> ResourceT (StageRIO st) ())
-> Utf8Builder
-> ResourceT (StageRIO st) (IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> ResourceT (StageRIO st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> ResourceT (StageRIO st) (IO ()))
-> Utf8Builder -> ResourceT (StageRIO 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 (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ())
-> ResourceT (StageRIO st) ReleaseKey -> ResourceT (StageRIO st) ()
forall a b. (a -> b) -> a -> b
$! IO () -> ResourceT (StageRIO 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 (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 :: forall renderpass pipelines resources.
Word64
-> Window
-> SurfaceKHR
-> SwapchainResources
-> renderpass
-> pipelines
-> Semaphore
-> (RefCounted, InternalState)
-> IORef [GPUWork]
-> (ReleaseKey, InternalState)
-> RecycledResources resources
-> Frame renderpass pipelines resources
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
(ReleaseKey, InternalState)
IORef [GPUWork]
Semaphore
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
fGPUWork :: IORef [GPUWork]
fResources :: (ReleaseKey, InternalState)
fRecycledResources :: RecycledResources rr
fRenderFinishedHostSemaphore :: Semaphore
fPipelines :: p
fRenderpass :: rp
fSwapchainResources :: SwapchainResources
..
    }

pattern INFLIGHT_FRAMES :: (Eq a, Num a) => a
pattern $bINFLIGHT_FRAMES :: a
$mINFLIGHT_FRAMES :: forall r a. (Eq a, Num a) => a -> (Void# -> r) -> (Void# -> 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 :: 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 <- IO (RecycledResources rr) -> RIO env (RecycledResources rr)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RecycledResources rr) -> RIO env (RecycledResources rr))
-> IO (RecycledResources rr) -> RIO env (RecycledResources rr)
forall a b. (a -> b) -> a -> b
$
    WaitResource (RecycledResources rr)
waitDumped WaitResource (RecycledResources rr)
-> (Either (IO (RecycledResources rr)) (RecycledResources rr)
    -> IO (RecycledResources rr))
-> IO (RecycledResources rr)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left IO (RecycledResources rr)
block ->
        IO (RecycledResources rr)
block
      Right RecycledResources rr
rs ->
        RecycledResources rr -> IO (RecycledResources rr)
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 (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 :: forall renderpass pipelines resources.
Word64
-> Window
-> SurfaceKHR
-> SwapchainResources
-> renderpass
-> pipelines
-> Semaphore
-> (RefCounted, InternalState)
-> IORef [GPUWork]
-> (ReleaseKey, InternalState)
-> RecycledResources resources
-> Frame renderpass pipelines resources
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
    , 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
Word64
(ReleaseKey, InternalState)
(RefCounted, InternalState)
IORef [GPUWork]
Window
Semaphore
SurfaceKHR
SwapchainResources
RecycledResources rr
fRecycledResources :: RecycledResources rr
fResources :: (ReleaseKey, InternalState)
fGPUWork :: IORef [GPUWork]
fStageResources :: (RefCounted, InternalState)
fRenderFinishedHostSemaphore :: Semaphore
fPipelines :: p
fRenderpass :: rp
fSwapchainResources :: SwapchainResources
fSurface :: SurfaceKHR
fWindow :: Window
fIndex :: Word64
$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: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 <- IO Extent2D -> RIO env Extent2D
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 <- Extent2D -> SwapchainResources -> RIO env SwapchainResources
forall env.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
Extent2D -> SwapchainResources -> RIO env SwapchainResources
recreateSwapchainResources 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
updateRenderpass SwapchainResources
newResources rp
fRenderpass

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

run
  :: ( HasLogFunc env
     , HasVulkan env
     , MonadResource (RIO env)
     )
  => (RecycledResources rr -> IO ())
  -> RIO (env, Frame rp p rr) a
  -> Frame rp p rr
  -> RIO env a
run :: (RecycledResources rr -> IO ())
-> RIO (env, Frame rp p rr) a -> Frame rp p rr -> RIO env a
run RecycledResources rr -> IO ()
recycle RIO (env, Frame rp p rr) a
render frame :: Frame rp p rr
frame@Frame{rp
p
Word64
(ReleaseKey, InternalState)
(RefCounted, InternalState)
IORef [GPUWork]
Window
Semaphore
SurfaceKHR
SwapchainResources
RecycledResources rr
fRecycledResources :: RecycledResources rr
fResources :: (ReleaseKey, InternalState)
fGPUWork :: IORef [GPUWork]
fStageResources :: (RefCounted, InternalState)
fRenderFinishedHostSemaphore :: Semaphore
fPipelines :: p
fRenderpass :: rp
fSwapchainResources :: SwapchainResources
fSurface :: SurfaceKHR
fWindow :: Window
fIndex :: Word64
$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: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 <- 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 oneSecondKhr :: Word64
oneSecondKhr = Word64
1e9
      -- logDebug $ "Waiting Frame " <> displayShow fIndex

      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GPUWork] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GPUWork]
waits) do
        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
oneSecondKhr RIO env Result -> (Result -> RIO env ()) -> RIO env ()
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 (1s) waiting for frame to finish on Device"
            String -> RIO env ()
forall (m :: * -> *) a. MonadThrow m => String -> m a
timeoutError String
"Time out (1s) 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 (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 (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 :: 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 :: (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 = CommandPoolCreateInfo :: CommandPoolCreateFlags
-> ("image index" ::: Word32) -> CommandPoolCreateInfo
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 (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 :: forall a.
Semaphore
-> Semaphore -> Queues CommandPool -> a -> RecycledResources a
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 :: 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 (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.waitSemaphores Device
device SemaphoreWaitInfo
waitInfo Word64
0
      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 (f :: * -> *) a. Applicative f => a -> f a
pure Result
r

timeoutError :: MonadThrow m => String -> m a
timeoutError :: String -> m a
timeoutError String
message =
  IOException -> 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 :: 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 (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 (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