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
(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
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
rp
sfRenderpass <- SwapchainResources -> ResourceT (RIO (App GlobalHandles st)) rp
sAllocateRP SwapchainResources
sfSwapchainResources
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
(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
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
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
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
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"
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
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
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
ReleaseKey -> RIO env ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ((ReleaseKey, InternalState) -> ReleaseKey
forall a b. (a, b) -> a
fst (ReleaseKey, InternalState)
fResources)
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
((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
..}
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
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