{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

{-| Per-frame state and the recycling-Frame loop. Each frame owns a binary
image-available semaphore and a command pool — those are 'RecycledResources'
that get handed back to a channel in 'VulkanContext' once the frame's GPU work
has completed. (The present-wait/render-finished semaphore is per swapchain
image, on the 'Vulkan.Utils.Swapchain.Swapchain', because it is only safe to
reuse once its image is re-acquired — not when the frame's render finishes.)

The host-side timeline semaphore (@fHostTimeline@) lives across frames:
each frame increments it to its own 'fIndex' on the GPU, and the host
waits on it inside the spawned wait-and-recycle thread.

This module requires Vulkan 1.2-level timeline-semaphore support. See
'frameInstanceRequirements' / 'frameDeviceRequirements' for the
extension/feature requirements to merge into your boot sequence.
-}
module Vulkan.Utils.Frame
  ( Frame (..)
  , initialFrame
  , advanceFrame
  , runFrame
  , recordCommands
  , queueSubmitFrame
  , acquireFrameImage
  , presentFrameImage
  , drainFrames
  , allocateTimelineSemaphore
  , frameInstanceRequirements
  , frameDeviceRequirements
  ) where

import Control.Concurrent (forkIO)
import Control.Exception (finally, mask_, throwIO)
import Control.Monad
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Resource
import Data.IORef
import qualified Data.Vector as V
import Data.Word
import System.IO (hPutStrLn, stderr)
import Vulkan.CStruct.Extends (SomeStruct (..), pattern (:&), pattern (::&))
import qualified Vulkan.Core10 as CommandBufferBeginInfo (CommandBufferBeginInfo (..))
import qualified Vulkan.Core10 as CommandPoolCreateInfo (CommandPoolCreateInfo (..))
import qualified Vulkan.Core10 as Vk
import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore as Timeline
import Vulkan.Exception (VulkanException (..))
import Vulkan.Extensions.VK_KHR_get_physical_device_properties2
import qualified Vulkan.Extensions.VK_KHR_swapchain as KHR
import Vulkan.Requirement (DeviceRequirement, InstanceRequirement (..))
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex (..))
import Vulkan.Utils.Queues (Queues (..))
import Vulkan.Utils.RefCounted (resourceTRefCount)
import qualified Vulkan.Utils.Requirements.TH as U
import Vulkan.Utils.Swapchain (Swapchain (..), sRelease)
import Vulkan.Utils.VulkanContext (RecycledResources (..), VulkanContext (..))
import Vulkan.Zero (zero)

data Frame = Frame
  { Frame -> Word64
fIndex :: Word64
  -- ^ Monotonic, used as the timeline-semaphore signal value for this frame.
  , Frame -> Swapchain
fSwapchain :: Swapchain
  {- ^ The swapchain this frame targets. Held by reference so a frame
  in flight keeps its swapchain alive across recreation.
  -}
  , Frame -> RecycledResources
fRecycled :: RecycledResources
  {- ^ This frame's image-available semaphore + command pool — borrowed from
  the recycle channel; returned at retire time.
  -}
  , Frame -> Semaphore
fHostTimeline :: Vk.Semaphore
  {- ^ Long-lived timeline semaphore. Each frame increments it to 'fIndex'
  on the GPU; the host wait thread blocks on this.
  -}
  , Frame -> IORef [(Semaphore, Word64)]
fGPUWork :: IORef [(Vk.Semaphore, Word64)]
  {- ^ (Timeline semaphore, value) pairs the host wait thread will block on.
  Appended to by 'queueSubmitFrame'.
  -}
  , Frame -> (ReleaseKey, InternalState)
fResources :: (ReleaseKey, InternalState)
  {- ^ ResourceT scope for frame-local allocations; closed when the frame
  retires. The 'ReleaseKey' lives in the outer ResourceT so the
  scope is freed cleanly even on early shutdown.
  -}
  }

{- | Instance-level requirements for the recycling 'Frame' machinery. Merge
with your application's other 'InstanceRequirement's at instance creation.

Required because checking @PhysicalDeviceTimelineSemaphoreFeatures@ at
physical-device pick time goes through @VkPhysicalDeviceFeatures2@, which
needs either Vulkan 1.1+ or this extension.
-}
frameInstanceRequirements :: [InstanceRequirement]
frameInstanceRequirements :: [InstanceRequirement]
frameInstanceRequirements =
  [ Maybe ByteString -> ByteString -> Word32 -> InstanceRequirement
RequireInstanceExtension
      Maybe ByteString
forall a. Maybe a
Nothing
      ByteString
forall a. (Eq a, IsString a) => a
KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME
      Word32
forall a. Bounded a => a
minBound
  ]

{- | The device-level requirements needed by 'runFrame' / 'queueSubmitFrame' /
'allocateTimelineSemaphore'. Merge into your other 'DeviceRequirement's when
calling 'Vulkan.Utils.Initialization.allocateDeviceFromRequirements'.
-}
frameDeviceRequirements :: [DeviceRequirement]
frameDeviceRequirements :: [DeviceRequirement]
frameDeviceRequirements =
  [U.reqs|
    VK_KHR_swapchain
    VK_KHR_timeline_semaphore
    PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore
  |]

----------------------------------------------------------------
-- Construction
----------------------------------------------------------------

{- | Build the initial frame with one spare 'RecycledResources' seeded
into the recycle channel. That, plus the set attached to this frame,
caps max-in-flight at 2 (CPU recording + GPU executing the previous).
-}
initialFrame :: (MonadResource m) => VulkanContext -> Swapchain -> m Frame
initialFrame :: forall (m :: * -> *).
MonadResource m =>
VulkanContext -> Swapchain -> m Frame
initialFrame VulkanContext
vc Swapchain
fSwapchain = do
  fRecycled <- VulkanContext -> m RecycledResources
forall (m :: * -> *).
MonadResource m =>
VulkanContext -> m RecycledResources
mkRecycledResources VulkanContext
vc
  spare <- mkRecycledResources vc
  liftIO (vcRecycleBin vc spare)
  (_, fHostTimeline) <- allocateTimelineSemaphore (vcDevice vc) 0
  fGPUWork <- liftIO $ newIORef mempty
  fResources <- allocate createInternalState closeInternalState
  liftIO $ runInternalState (resourceTRefCount (sRelease fSwapchain)) (snd fResources)
  pure Frame{fIndex = 1, ..}

{- | Build the next frame, taking one set of recycled resources from the bin.
Caller passes the (possibly-recreated) 'Swapchain'.
-}
advanceFrame
  :: (MonadResource m)
  => VulkanContext
  -> Swapchain
  -- ^ Same as old, or freshly recreated
  -> Frame
  -- ^ The just-finished frame
  -> m Frame
advanceFrame :: forall (m :: * -> *).
MonadResource m =>
VulkanContext -> Swapchain -> Frame -> m Frame
advanceFrame VulkanContext
vc Swapchain
sc Frame
f = do
  fRecycled <-
    IO RecycledResources -> m RecycledResources
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RecycledResources -> m RecycledResources)
-> IO RecycledResources -> m RecycledResources
forall a b. (a -> b) -> a -> b
$
      VulkanContext
-> IO (Either (IO RecycledResources) RecycledResources)
vcRecycleNib VulkanContext
vc IO (Either (IO RecycledResources) RecycledResources)
-> (Either (IO RecycledResources) RecycledResources
    -> IO RecycledResources)
-> IO RecycledResources
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left IO RecycledResources
block -> IO RecycledResources
block
        Right RecycledResources
rr -> RecycledResources -> IO RecycledResources
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecycledResources
rr
  fGPUWork <- liftIO $ newIORef mempty
  fResources <- allocate createInternalState closeInternalState
  liftIO $ runInternalState (resourceTRefCount (sRelease sc)) (snd fResources)
  pure
    Frame
      { fIndex = succ (fIndex f)
      , fSwapchain = sc
      , fRecycled
      , fHostTimeline = fHostTimeline f
      , fGPUWork
      , fResources
      }

----------------------------------------------------------------
-- Loop
----------------------------------------------------------------

{- | Run a per-frame action against this frame's per-frame ResourceT scope,
then asynchronously wait for the GPU work and recycle. The wait/recycle
runs in a forked thread so the next frame can begin recording immediately.

Anything 'allocate'd inside @action@ is freed when the frame retires.
-}
runFrame :: VulkanContext -> Frame -> ResourceT IO a -> IO a
runFrame :: forall a. VulkanContext -> Frame -> ResourceT IO a -> IO a
runFrame VulkanContext
vc Frame
f ResourceT IO a
action =
  ResourceT IO a -> InternalState -> IO a
forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
runInternalState ResourceT IO a
action ((ReleaseKey, InternalState) -> InternalState
forall a b. (a, b) -> b
snd (Frame -> (ReleaseKey, InternalState)
fResources Frame
f))
    IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` VulkanContext -> Frame -> IO ()
waitAndRecycle VulkanContext
vc Frame
f

waitAndRecycle :: VulkanContext -> Frame -> IO ()
waitAndRecycle :: VulkanContext -> Frame -> IO ()
waitAndRecycle VulkanContext
vc Frame
f = do
  waits <- IORef [(Semaphore, Word64)] -> IO [(Semaphore, Word64)]
forall a. IORef a -> IO a
readIORef (Frame -> IORef [(Semaphore, Word64)]
fGPUWork Frame
f)
  void . forkIO $ do
    unless (null waits) $ do
      let waitInfo =
            SemaphoreWaitInfo
forall a. Zero a => a
zero
              { semaphores = V.fromList (fst <$> waits)
              , values = V.fromList (snd <$> waits)
              }
      r <- waitTwice (vcDevice vc) waitInfo oneSecond
      case r of
        Result
Vk.TIMEOUT -> Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Frame wait timed out (1s) — GPU may be hung"
        Result
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    -- Pool reuse: reset, dropping all recorded buffers.
    Vk.resetCommandPool
      (vcDevice vc)
      (rrCommandPool (fRecycled f))
      Vk.COMMAND_POOL_RESET_RELEASE_RESOURCES_BIT
    -- Free the per-frame ResourceT scope. Must precede the channel deposit so
    -- the deposit signals "all per-frame cleanup done" — otherwise the next
    -- frame could pick up the recycled pool while this frame's cleanup is
    -- still calling vkFreeCommandBuffers on it.
    release (fst (fResources f))
    -- Hand the borrowed resources back to whoever's waiting on them.
    vcRecycleBin vc (fRecycled f)
  where
    oneSecond :: Word64
    oneSecond :: Word64
oneSecond = Word64
1000000000

{- | Allocate a primary command buffer from this frame's recycled command pool,
begin it with 'Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT', run the caller's
recording action, end recording, and return the buffer ready to hand to
'queueSubmitFrame'.

For a non-standard begin shape (secondary level, different usage flags,
inheritance info) call 'Vk.withCommandBuffers' and 'Vk.useCommandBuffer'
directly.
-}
recordCommands
  :: (MonadResource m, MonadFail m)
  => VulkanContext
  -> Frame
  -> (Vk.CommandBuffer -> m ())
  -> m Vk.CommandBuffer
{-# INLINE recordCommands #-}
recordCommands :: forall (m :: * -> *).
(MonadResource m, MonadFail m) =>
VulkanContext
-> Frame -> (CommandBuffer -> m ()) -> m CommandBuffer
recordCommands VulkanContext
vc Frame{RecycledResources
fRecycled :: Frame -> RecycledResources
fRecycled :: RecycledResources
fRecycled} CommandBuffer -> m ()
record = do
  (_, [cb]) <-
    Device
-> CommandBufferAllocateInfo
-> (IO (Vector CommandBuffer)
    -> (Vector CommandBuffer -> IO ())
    -> m (ReleaseKey, Vector CommandBuffer))
-> m (ReleaseKey, Vector CommandBuffer)
forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandBufferAllocateInfo
-> (io (Vector CommandBuffer)
    -> (Vector CommandBuffer -> io ()) -> r)
-> r
Vk.withCommandBuffers
      (VulkanContext -> Device
vcDevice VulkanContext
vc)
      CommandBufferAllocateInfo
forall a. Zero a => a
zero
        { Vk.commandPool = rrCommandPool fRecycled
        , Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY
        , Vk.commandBufferCount = 1
        }
      IO (Vector CommandBuffer)
-> (Vector CommandBuffer -> IO ())
-> m (ReleaseKey, Vector CommandBuffer)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
  Vk.useCommandBuffer cb zero{CommandBufferBeginInfo.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT} $
    record cb
  pure cb

{- | Submit a per-frame command buffer batch and record the timeline-wait
bookkeeping the host wait thread will block on.

Builds the standard frame submit from context/frame: waits on the frame's
image-available semaphore at @COLOR_ATTACHMENT_OUTPUT@, signals the
swapchain's per-image render-finished semaphore (at @imageIndex@) plus its
timeline value, and submits on the graphics queue.

For a non-standard submit shape (multiple submit infos, different wait
stage, extra signals), call 'Vk.queueSubmit' directly and append
@(fHostTimeline f, fIndex f)@ to @fGPUWork f@.
-}
queueSubmitFrame
  :: (MonadIO m)
  => VulkanContext
  -> Frame
  -> Word32
  {- ^ Acquired image index (from 'acquireFrameImage'); selects the per-image
  present-wait semaphore to signal.
  -}
  -> V.Vector Vk.CommandBuffer
  -> m ()
{-# INLINE queueSubmitFrame #-}
queueSubmitFrame :: forall (m :: * -> *).
MonadIO m =>
VulkanContext -> Frame -> Word32 -> Vector CommandBuffer -> m ()
queueSubmitFrame VulkanContext
vc Frame{Word64
(ReleaseKey, InternalState)
IORef [(Semaphore, Word64)]
Semaphore
Swapchain
RecycledResources
fIndex :: Frame -> Word64
fSwapchain :: Frame -> Swapchain
fRecycled :: Frame -> RecycledResources
fHostTimeline :: Frame -> Semaphore
fGPUWork :: Frame -> IORef [(Semaphore, Word64)]
fResources :: Frame -> (ReleaseKey, InternalState)
fIndex :: Word64
fSwapchain :: Swapchain
fRecycled :: RecycledResources
fHostTimeline :: Semaphore
fGPUWork :: IORef [(Semaphore, Word64)]
fResources :: (ReleaseKey, InternalState)
..} Word32
imageIndex Vector CommandBuffer
cbs = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  Queue -> Vector (SomeStruct SubmitInfo) -> Fence -> IO ()
forall (io :: * -> *).
MonadIO io =>
Queue -> Vector (SomeStruct SubmitInfo) -> Fence -> io ()
Vk.queueSubmit Queue
gQ [SubmitInfo '[TimelineSemaphoreSubmitInfo] -> SomeStruct SubmitInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct SubmitInfo '[TimelineSemaphoreSubmitInfo]
submitInfo] Fence
forall a. IsHandle a => a
Vk.NULL_HANDLE
  IORef [(Semaphore, Word64)]
-> ([(Semaphore, Word64)] -> ([(Semaphore, Word64)], ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [(Semaphore, Word64)]
fGPUWork (([(Semaphore, Word64)] -> ([(Semaphore, Word64)], ())) -> IO ())
-> ([(Semaphore, Word64)] -> ([(Semaphore, Word64)], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Semaphore, Word64)]
jobs -> ((Semaphore
fHostTimeline, Word64
fIndex) (Semaphore, Word64)
-> [(Semaphore, Word64)] -> [(Semaphore, Word64)]
forall a. a -> [a] -> [a]
: [(Semaphore, Word64)]
jobs, ())
  where
    gQ :: Queue
gQ = (QueueFamilyIndex, Queue) -> Queue
forall a b. (a, b) -> b
snd (Queues (QueueFamilyIndex, Queue) -> (QueueFamilyIndex, Queue)
forall a. Queues a -> a
qGraphics (VulkanContext -> Queues (QueueFamilyIndex, Queue)
vcQueues VulkanContext
vc))
    renderFinished :: Semaphore
renderFinished = Swapchain -> Vector Semaphore
sRenderFinished Swapchain
fSwapchain Vector Semaphore -> Int -> Semaphore
forall a. Vector a -> Int -> a
V.! Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
imageIndex
    submitInfo :: SubmitInfo '[TimelineSemaphoreSubmitInfo]
submitInfo =
      SubmitInfo '[]
forall a. Zero a => a
zero
        { Vk.waitSemaphores = [rrImageAvailable]
        , Vk.waitDstStageMask = [Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT]
        , Vk.commandBuffers = fmap Vk.commandBufferHandle cbs
        , Vk.signalSemaphores = [renderFinished, fHostTimeline]
        }
        SubmitInfo '[]
-> Chain '[TimelineSemaphoreSubmitInfo]
-> SubmitInfo '[TimelineSemaphoreSubmitInfo]
forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& TimelineSemaphoreSubmitInfo
forall a. Zero a => a
zero
          { waitSemaphoreValues = [1]
          , signalSemaphoreValues = [1, fIndex]
          }
          TimelineSemaphoreSubmitInfo
-> Chain '[] -> Chain '[TimelineSemaphoreSubmitInfo]
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ()
    RecycledResources{Semaphore
rrImageAvailable :: Semaphore
rrImageAvailable :: RecycledResources -> Semaphore
rrImageAvailable} = RecycledResources
fRecycled

{- | Acquire the next swapchain image for this frame, signalling the frame's
image-available semaphore on completion.

The acquire result is returned alongside the image index so the caller can
thread it into 'presentFrameImage', which honours 'SUBOPTIMAL_KHR' from
either side by raising 'ERROR_OUT_OF_DATE_KHR' to drive a swapchain
recreation. Timeouts and unexpected results are also translated to
'ERROR_OUT_OF_DATE_KHR' — the main loop's swapchain-recreation path is the
right place to recover.
-}
acquireFrameImage :: (MonadIO m) => VulkanContext -> Frame -> m (Vk.Result, Word32)
{-# INLINE acquireFrameImage #-}
acquireFrameImage :: forall (m :: * -> *).
MonadIO m =>
VulkanContext -> Frame -> m (Result, Word32)
acquireFrameImage VulkanContext
vc Frame{Word64
(ReleaseKey, InternalState)
IORef [(Semaphore, Word64)]
Semaphore
Swapchain
RecycledResources
fIndex :: Frame -> Word64
fSwapchain :: Frame -> Swapchain
fRecycled :: Frame -> RecycledResources
fHostTimeline :: Frame -> Semaphore
fGPUWork :: Frame -> IORef [(Semaphore, Word64)]
fResources :: Frame -> (ReleaseKey, InternalState)
fIndex :: Word64
fSwapchain :: Swapchain
fRecycled :: RecycledResources
fHostTimeline :: Semaphore
fGPUWork :: IORef [(Semaphore, Word64)]
fResources :: (ReleaseKey, InternalState)
..} =
  IO (Result, Word32) -> m (Result, Word32)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Result, Word32) -> m (Result, Word32))
-> IO (Result, Word32) -> m (Result, Word32)
forall a b. (a -> b) -> a -> b
$
    IO (Result, Word32)
acquire IO (Result, Word32)
-> ((Result, Word32) -> IO (Result, Word32)) -> IO (Result, Word32)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      r :: (Result, Word32)
r@(Result
Vk.SUCCESS, Word32
_) -> (Result, Word32) -> IO (Result, Word32)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result, Word32)
r
      r :: (Result, Word32)
r@(Result
Vk.SUBOPTIMAL_KHR, Word32
_) -> (Result, Word32) -> IO (Result, Word32)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result, Word32)
r
      (Result, Word32)
_ -> VulkanException -> IO (Result, Word32)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (Result -> VulkanException
VulkanException Result
Vk.ERROR_OUT_OF_DATE_KHR)
  where
    acquire :: IO (Result, Word32)
acquire =
      Device
-> SwapchainKHR
-> Word64
-> Semaphore
-> Fence
-> IO (Result, Word32)
forall (io :: * -> *).
MonadIO io =>
Device
-> SwapchainKHR
-> Word64
-> Semaphore
-> Fence
-> io (Result, Word32)
KHR.acquireNextImageKHRSafe
        (VulkanContext -> Device
vcDevice VulkanContext
vc)
        (Swapchain -> SwapchainKHR
sSwapchain Swapchain
fSwapchain)
        Word64
oneSecond
        (RecycledResources -> Semaphore
rrImageAvailable RecycledResources
fRecycled)
        Fence
forall a. IsHandle a => a
Vk.NULL_HANDLE

    oneSecond :: Word64
    oneSecond :: Word64
oneSecond = Word64
1000000000

{- | Present this frame's acquired image, waiting on the swapchain's per-image
render-finished semaphore (at @imageIndex@). Presents on the graphics queue
(@qGraphics . vcQueues@).

If either the prior acquire (passed in) or this present reports
'SUBOPTIMAL_KHR', raises 'ERROR_OUT_OF_DATE_KHR' so the main loop
recreates the swapchain.
-}
presentFrameImage :: (MonadIO m) => VulkanContext -> Frame -> Vk.Result -> Word32 -> m ()
{-# INLINE presentFrameImage #-}
presentFrameImage :: forall (m :: * -> *).
MonadIO m =>
VulkanContext -> Frame -> Result -> Word32 -> m ()
presentFrameImage VulkanContext
vc Frame
f Result
acquireResult Word32
imageIndex = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  presentResult <-
    Queue -> PresentInfoKHR '[] -> IO Result
forall (a :: [*]) (io :: * -> *).
(Extendss PresentInfoKHR a, PokeChain a, MonadIO io) =>
Queue -> PresentInfoKHR a -> io Result
KHR.queuePresentKHR
      Queue
gQ
      PresentInfoKHR '[]
forall a. Zero a => a
zero
        { KHR.waitSemaphores = [renderFinished]
        , KHR.swapchains = [sSwapchain (fSwapchain f)]
        , KHR.imageIndices = [imageIndex]
        }
  when (acquireResult == Vk.SUBOPTIMAL_KHR || presentResult == Vk.SUBOPTIMAL_KHR) $
    throwIO (VulkanException Vk.ERROR_OUT_OF_DATE_KHR)
  where
    renderFinished :: Semaphore
renderFinished = Swapchain -> Vector Semaphore
sRenderFinished (Frame -> Swapchain
fSwapchain Frame
f) Vector Semaphore -> Int -> Semaphore
forall a. Vector a -> Int -> a
V.! Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
imageIndex
    gQ :: Queue
gQ = (QueueFamilyIndex, Queue) -> Queue
forall a b. (a, b) -> b
snd (Queues (QueueFamilyIndex, Queue) -> (QueueFamilyIndex, Queue)
forall a. Queues a -> a
qGraphics (VulkanContext -> Queues (QueueFamilyIndex, Queue)
vcQueues VulkanContext
vc))

{- | Shutdown drain: spawn the unrendered current frame's wait/recycle thread,
then block on the recycle channel until both this frame's and the previous
in-flight frame's deposits have arrived. After this returns, every forked
wait thread has run its per-frame cleanup, so the outer 'ResourceT' is safe
to tear down GPU resources.

Assumes max-in-flight is 2 (see 'initialFrame').
-}
drainFrames :: VulkanContext -> Frame -> IO ()
drainFrames :: VulkanContext -> Frame -> IO ()
drainFrames VulkanContext
vc Frame
f = do
  VulkanContext -> Frame -> IO ()
waitAndRecycle VulkanContext
vc Frame
f
  let take1 :: IO RecycledResources
take1 = VulkanContext
-> IO (Either (IO RecycledResources) RecycledResources)
vcRecycleNib VulkanContext
vc IO (Either (IO RecycledResources) RecycledResources)
-> (Either (IO RecycledResources) RecycledResources
    -> IO RecycledResources)
-> IO RecycledResources
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IO RecycledResources -> IO RecycledResources)
-> (RecycledResources -> IO RecycledResources)
-> Either (IO RecycledResources) RecycledResources
-> IO RecycledResources
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either IO RecycledResources -> IO RecycledResources
forall a. a -> a
id RecycledResources -> IO RecycledResources
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  _ <- IO RecycledResources
take1
  _ <- take1
  pure ()

----------------------------------------------------------------
-- Small helpers
----------------------------------------------------------------

-- | Allocate a timeline semaphore initialised to the given value.
allocateTimelineSemaphore :: (MonadResource m) => Vk.Device -> Word64 -> m (ReleaseKey, Vk.Semaphore)
allocateTimelineSemaphore :: forall (m :: * -> *).
MonadResource m =>
Device -> Word64 -> m (ReleaseKey, Semaphore)
allocateTimelineSemaphore Device
dev Word64
initial =
  Device
-> SemaphoreCreateInfo '[SemaphoreTypeCreateInfo]
-> Maybe AllocationCallbacks
-> (IO Semaphore
    -> (Semaphore -> IO ()) -> m (ReleaseKey, Semaphore))
-> m (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
dev
    (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
SemaphoreTypeCreateInfo SemaphoreType
SEMAPHORE_TYPE_TIMELINE Word64
initial SemaphoreTypeCreateInfo
-> Chain '[] -> Chain '[SemaphoreTypeCreateInfo]
forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ())
    Maybe AllocationCallbacks
forall a. Maybe a
Nothing
    IO Semaphore -> (Semaphore -> IO ()) -> m (ReleaseKey, Semaphore)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate

----------------------------------------------------------------
-- Internals
----------------------------------------------------------------

{- | Build one set of recycled resources: a binary image-available semaphore
+ a command pool keyed to the graphics queue family. (The present-wait
semaphore is per swapchain image, on the 'Swapchain', not here.)
-}
mkRecycledResources :: (MonadResource m) => VulkanContext -> m RecycledResources
mkRecycledResources :: forall (m :: * -> *).
MonadResource m =>
VulkanContext -> m RecycledResources
mkRecycledResources VulkanContext
vc = do
  (_, rrImageAvailable) <-
    Device
-> SemaphoreCreateInfo '[SemaphoreTypeCreateInfo]
-> Maybe AllocationCallbacks
-> (IO Semaphore
    -> (Semaphore -> IO ()) -> m (ReleaseKey, Semaphore))
-> m (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
dev
      (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
SemaphoreTypeCreateInfo SemaphoreType
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 ()) -> m (ReleaseKey, Semaphore)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
  (_, rrCommandPool) <-
    Vk.withCommandPool
      dev
      zero{CommandPoolCreateInfo.queueFamilyIndex = qfi}
      Nothing
      allocate
  pure RecycledResources{..}
  where
    dev :: Device
dev = VulkanContext -> Device
vcDevice VulkanContext
vc
    (QueueFamilyIndex Word32
qfi, Queue
_) = Queues (QueueFamilyIndex, Queue) -> (QueueFamilyIndex, Queue)
forall a. Queues a -> a
qGraphics (VulkanContext -> Queues (QueueFamilyIndex, Queue)
vcQueues VulkanContext
vc)

{- | Wait for some semaphores; if the wait times out, give the device one
more chance with a zero timeout. Catches the case where the host was
suspended during the wait and the GPU has actually finished.
-}
waitTwice :: Vk.Device -> SemaphoreWaitInfo -> Word64 -> IO Vk.Result
waitTwice :: Device -> SemaphoreWaitInfo -> Word64 -> IO Result
waitTwice Device
dev SemaphoreWaitInfo
waitInfo Word64
t =
  Device -> SemaphoreWaitInfo -> Word64 -> IO Result
forall (io :: * -> *).
MonadIO io =>
Device -> SemaphoreWaitInfo -> Word64 -> io Result
Timeline.waitSemaphoresSafe Device
dev SemaphoreWaitInfo
waitInfo Word64
t IO Result -> (Result -> IO Result) -> IO Result
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Result
Vk.TIMEOUT -> Device -> SemaphoreWaitInfo -> Word64 -> IO Result
forall (io :: * -> *).
MonadIO io =>
Device -> SemaphoreWaitInfo -> Word64 -> io Result
Timeline.waitSemaphores Device
dev SemaphoreWaitInfo
waitInfo Word64
0
    Result
r -> Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r