module Engine.Frame
( Frame(..)
, initial
, run
, advance
, queueSubmit
, RecycledResources(..)
, initialRecycledResources
, timeoutError
) where
import RIO
import Control.Monad.Trans.Resource (ResourceT, MonadResource, allocate, release)
import Control.Monad.Trans.Resource qualified as ResourceT
import GHC.IO.Exception (IOErrorType(TimeExpired), IOException(IOError))
import RIO.App (appEnv)
import RIO.Text qualified as Text
import RIO.Vector qualified as Vector
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore qualified as Vk12
import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&))
import Vulkan.NamedType ((:::))
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))
import Vulkan.Zero (zero)
import Engine.DataRecycler (DumpResource, WaitResource)
import Engine.Setup.Window qualified as Window
import Engine.Types (GlobalHandles(..), StageRIO, Stage(..), Frame(..), GPUWork, RecycledResources(..))
import Engine.Types.Options (optionsPresent, optionsMsaa)
import Engine.Types.RefCounted (newRefCounted)
import Engine.Vulkan.Swapchain (SwapchainResources(..), SwapchainInfo(..), allocSwapchainResources, recreateSwapchainResources)
import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, RenderPass(..), Queues)
initial
:: Maybe SwapchainResources
-> DumpResource (RecycledResources rr)
-> Stage rp p rr st
-> StageRIO st (Frame rp p rr)
initial :: forall rr rp p st.
Maybe SwapchainResources
-> DumpResource (RecycledResources rr)
-> Stage rp p rr st
-> StageRIO st (Frame rp p rr)
initial Maybe SwapchainResources
oldSR DumpResource (RecycledResources rr)
dumpResource Stage{Text
StageRIO st a
StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
st -> rr -> StageFrameRIO rp p rr st ()
a -> StageRIO st ()
CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
Queues CommandPool
-> rp -> p -> ResourceT (RIO (App GlobalHandles st)) rr
SwapchainResources -> ResourceT (RIO (App GlobalHandles st)) rp
SwapchainResources
-> rp -> ResourceT (RIO (App GlobalHandles st)) p
$sel:sAfterLoop:Stage :: ()
$sel:sRecordCommands:Stage :: forall rp p rr st.
Stage rp p rr st
-> CommandBuffer
-> rr
-> ("image index" ::: Word32)
-> StageFrameRIO rp p rr st ()
$sel:sUpdateBuffers:Stage :: forall rp p rr st.
Stage rp p rr st -> st -> rr -> StageFrameRIO rp p rr st ()
$sel:sBeforeLoop:Stage :: ()
$sel:sInitialRR:Stage :: forall rp p rr st.
Stage rp p rr st
-> Queues CommandPool -> rp -> p -> ResourceT (StageRIO st) rr
$sel:sInitialRS:Stage :: forall rp p rr st.
Stage rp p rr st
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
$sel:sAllocateP:Stage :: forall rp p rr st.
Stage rp p rr st
-> SwapchainResources -> rp -> ResourceT (StageRIO st) p
$sel:sAllocateRP:Stage :: forall rp p rr st.
Stage rp p rr st
-> SwapchainResources -> ResourceT (StageRIO st) rp
$sel:sTitle:Stage :: forall rp p rr st. Stage rp p rr st -> Text
sAfterLoop :: a -> StageRIO st ()
sRecordCommands :: CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
sUpdateBuffers :: st -> rr -> StageFrameRIO rp p rr st ()
sBeforeLoop :: StageRIO st a
sInitialRR :: Queues CommandPool
-> rp -> p -> ResourceT (RIO (App GlobalHandles st)) rr
sInitialRS :: StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
sAllocateP :: SwapchainResources
-> rp -> ResourceT (RIO (App GlobalHandles st)) p
sAllocateRP :: SwapchainResources -> ResourceT (RIO (App GlobalHandles st)) rp
sTitle :: Text
..} = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Making initial frame"
GlobalHandles{Window
Allocator
Var Extent2D
StageSwitchVar
SurfaceKHR
Device
Instance
PhysicalDevice
PhysicalDeviceInfo
Queues (QueueFamilyIndex, Queue)
Options
$sel:ghStageSwitch:GlobalHandles :: GlobalHandles -> StageSwitchVar
$sel:ghScreenVar:GlobalHandles :: GlobalHandles -> Var Extent2D
$sel:ghQueues:GlobalHandles :: GlobalHandles -> Queues (QueueFamilyIndex, Queue)
$sel:ghAllocator:GlobalHandles :: GlobalHandles -> Allocator
$sel:ghDevice:GlobalHandles :: GlobalHandles -> Device
$sel:ghPhysicalDeviceInfo:GlobalHandles :: GlobalHandles -> PhysicalDeviceInfo
$sel:ghPhysicalDevice:GlobalHandles :: GlobalHandles -> PhysicalDevice
$sel:ghInstance:GlobalHandles :: GlobalHandles -> Instance
$sel:ghSurface:GlobalHandles :: GlobalHandles -> SurfaceKHR
$sel:ghWindow:GlobalHandles :: GlobalHandles -> Window
$sel:ghOptions:GlobalHandles :: GlobalHandles -> Options
ghStageSwitch :: StageSwitchVar
ghScreenVar :: Var Extent2D
ghQueues :: Queues (QueueFamilyIndex, Queue)
ghAllocator :: Allocator
ghDevice :: Device
ghPhysicalDeviceInfo :: PhysicalDeviceInfo
ghPhysicalDevice :: PhysicalDevice
ghInstance :: Instance
ghSurface :: SurfaceKHR
ghWindow :: Window
ghOptions :: Options
..} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall env st. App env st -> env
appEnv
let device :: Device
device = Device
ghDevice
let
fPresent :: Maybe PresentModeKHR
fPresent = Options -> Maybe PresentModeKHR
optionsPresent Options
ghOptions
fMSAA :: SampleCountFlagBits
fMSAA = Options -> SampleCountFlagBits
optionsMsaa Options
ghOptions
SwapchainResources
sfSwapchainResources <- case Maybe SwapchainResources
oldSR of
Maybe SwapchainResources
Nothing -> do
Extent2D
windowSize <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Window -> IO Extent2D
Window.getExtent2D Window
ghWindow
let oldSwapchain :: SwapchainKHR
oldSwapchain = forall a. IsHandle a => a
Vk.NULL_HANDLE
forall env.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
Maybe PresentModeKHR
-> SampleCountFlagBits
-> SwapchainKHR
-> Extent2D
-> SurfaceKHR
-> Var Extent2D
-> RIO env SwapchainResources
allocSwapchainResources
Maybe PresentModeKHR
fPresent
SampleCountFlagBits
fMSAA
SwapchainKHR
oldSwapchain
Extent2D
windowSize
SurfaceKHR
ghSurface
Var Extent2D
ghScreenVar
Just SwapchainResources
old ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure SwapchainResources
old
(ReleaseKey
stageKey, InternalState
stageResources) <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate forall (m :: * -> *). MonadIO m => m InternalState
ResourceT.createInternalState forall (m :: * -> *). MonadIO m => InternalState -> m ()
ResourceT.closeInternalState
RefCounted
stageRefCounted <- forall (m :: * -> *). MonadIO m => IO () -> m RefCounted
newRefCounted forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
stageKey
(SwapchainResources, rp, p, Semaphore, RecycledResources rr)
semiFrame <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. ResourceT m a -> InternalState -> m a
ResourceT.runInternalState InternalState
stageResources do
IO ()
debugAlloc <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Allocating inside stage " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
IO ()
debugRelease <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Releasing inside stage " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *) a.
MonadResource m =>
IO a -> IO () -> m ReleaseKey
ResourceT.allocate_ IO ()
debugAlloc IO ()
debugRelease
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) <- forall (a :: [*]) (io :: * -> *) r.
(Extendss SemaphoreCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> SemaphoreCreateInfo a
-> Maybe AllocationCallbacks
-> (io Semaphore -> (Semaphore -> io ()) -> r)
-> r
Vk.withSemaphore
Device
device
(forall a. Zero a => a
zero forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& SemaphoreType -> Word64 -> SemaphoreTypeCreateInfo
Vk12.SemaphoreTypeCreateInfo SemaphoreType
Vk12.SEMAPHORE_TYPE_TIMELINE Word64
0 forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ())
forall a. Maybe a
Nothing
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Creating initial recycled resources for stage " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
RecycledResources rr
sfRecycledResources <- forall env rp p rr.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
(Queues CommandPool -> rp -> p -> ResourceT (RIO env) rr)
-> rp -> p -> ResourceT (RIO env) (RecycledResources rr)
initialRecycledResources Queues CommandPool
-> rp -> p -> ResourceT (RIO (App GlobalHandles st)) rr
sInitialRR rp
sfRenderpass p
sfPipelines
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (forall a. (Eq a, Num a) => a
INFLIGHT_FRAMES forall a. Num a => a -> a -> a
- Int
1) do
RecycledResources rr
resources <- forall env rp p rr.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
(Queues CommandPool -> rp -> p -> ResourceT (RIO env) rr)
-> rp -> p -> ResourceT (RIO env) (RecycledResources rr)
initialRecycledResources Queues CommandPool
-> rp -> p -> ResourceT (RIO (App GlobalHandles st)) rr
sInitialRR rp
sfRenderpass p
sfPipelines
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DumpResource (RecycledResources rr)
dumpResource RecycledResources rr
resources
IO ()
releaseDataDebug <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Releasing recycled resources for stage " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register IO ()
releaseDataDebug
pure
( SwapchainResources
sfSwapchainResources
, rp
sfRenderpass
, p
sfPipelines
, Semaphore
sfRenderFinishedHostSemaphore
, RecycledResources rr
sfRecycledResources
)
let
(SwapchainResources
fSwapchainResources, rp
fRenderpass, p
fPipelines, Semaphore
fRenderFinishedHostSemaphore, RecycledResources rr
fRecycledResources) = (SwapchainResources, rp, p, Semaphore, RecycledResources rr)
semiFrame
(ReleaseKey, InternalState)
fResources <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate forall (m :: * -> *). MonadIO m => m InternalState
ResourceT.createInternalState forall (m :: * -> *). MonadIO m => InternalState -> m ()
ResourceT.closeInternalState
IORef [GPUWork]
fGPUWork <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Monoid a => a
mempty
pure Frame
{ $sel:fIndex:Frame :: Word64
fIndex = Word64
1
, $sel:fWindow:Frame :: Window
fWindow = Window
ghWindow
, $sel:fSurface:Frame :: SurfaceKHR
fSurface = SurfaceKHR
ghSurface
, $sel:fStageResources:Frame :: (RefCounted, InternalState)
fStageResources = (RefCounted
stageRefCounted, InternalState
stageResources)
, rp
p
Maybe PresentModeKHR
(ReleaseKey, InternalState)
IORef [GPUWork]
Semaphore
SampleCountFlagBits
SwapchainResources
RecycledResources rr
$sel:fRecycledResources:Frame :: RecycledResources rr
$sel:fResources:Frame :: (ReleaseKey, InternalState)
$sel:fGPUWork:Frame :: IORef [GPUWork]
$sel:fRenderFinishedHostSemaphore:Frame :: Semaphore
$sel:fPipelines:Frame :: p
$sel:fRenderpass:Frame :: rp
$sel:fSwapchainResources:Frame :: SwapchainResources
$sel:fMSAA:Frame :: SampleCountFlagBits
$sel:fPresent:Frame :: Maybe PresentModeKHR
fGPUWork :: IORef [GPUWork]
fResources :: (ReleaseKey, InternalState)
fRecycledResources :: RecycledResources rr
fRenderFinishedHostSemaphore :: Semaphore
fPipelines :: p
fRenderpass :: rp
fSwapchainResources :: SwapchainResources
fMSAA :: SampleCountFlagBits
fPresent :: Maybe PresentModeKHR
..
}
pattern INFLIGHT_FRAMES :: (Eq a, Num a) => a
pattern $bINFLIGHT_FRAMES :: forall a. (Eq a, Num a) => a
$mINFLIGHT_FRAMES :: forall {r} {a}.
(Eq a, Num a) =>
a -> ((# #) -> r) -> ((# #) -> r) -> r
INFLIGHT_FRAMES = 2
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 <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO WaitResource (RecycledResources rr)
waitDumped forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left IO (RecycledResources rr)
block ->
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
15e6 (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (RecycledResources rr)
block) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (RecycledResources rr)
Nothing -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords
[ Text
"Timed out waiting for recycled resources."
, Text
"A recycler thread is stuck on timeline semaphore or something."
, Text
"Try running with --recycler-wait 15000 or a similar value."
]
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
Just RecycledResources rr
rr ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecycledResources rr
rr
Right RecycledResources rr
rs ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure RecycledResources rr
rs
(SwapchainResources
fSwapchainResources, rp
fRenderpass) <- Frame rp p rr -> RIO env (SwapchainResources, rp)
getNext Frame rp p rr
f
IORef [GPUWork]
fGPUWork <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Monoid a => a
mempty
(ReleaseKey, InternalState)
fResources <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate forall (m :: * -> *). MonadIO m => m InternalState
ResourceT.createInternalState forall (m :: * -> *). MonadIO m => InternalState -> m ()
ResourceT.closeInternalState
pure Frame
{ $sel:fIndex:Frame :: Word64
fIndex = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
fIndex Frame rp p rr
f forall a. Num a => a -> a -> a
+ Word64
1
, $sel:fWindow:Frame :: Window
fWindow = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
fWindow Frame rp p rr
f
, $sel:fSurface:Frame :: SurfaceKHR
fSurface = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SurfaceKHR
fSurface Frame rp p rr
f
, $sel:fPipelines:Frame :: p
fPipelines = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> pipelines
fPipelines Frame rp p rr
f
, $sel:fRenderFinishedHostSemaphore:Frame :: Semaphore
fRenderFinishedHostSemaphore = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Semaphore
fRenderFinishedHostSemaphore Frame rp p rr
f
, $sel:fStageResources:Frame :: (RefCounted, InternalState)
fStageResources = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
fStageResources Frame rp p rr
f
, $sel:fPresent:Frame :: Maybe PresentModeKHR
fPresent = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Maybe PresentModeKHR
fPresent Frame rp p rr
f
, $sel:fMSAA:Frame :: SampleCountFlagBits
fMSAA = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SampleCountFlagBits
fMSAA Frame rp p rr
f
, SwapchainResources
fSwapchainResources :: SwapchainResources
$sel:fSwapchainResources:Frame :: SwapchainResources
fSwapchainResources
, rp
fRenderpass :: rp
$sel:fRenderpass:Frame :: rp
fRenderpass
, IORef [GPUWork]
fGPUWork :: IORef [GPUWork]
$sel:fGPUWork:Frame :: IORef [GPUWork]
fGPUWork
, (ReleaseKey, InternalState)
fResources :: (ReleaseKey, InternalState)
$sel:fResources:Frame :: (ReleaseKey, InternalState)
fResources
, RecycledResources rr
fRecycledResources :: RecycledResources rr
$sel:fRecycledResources:Frame :: RecycledResources rr
fRecycledResources
}
where
getNext :: Frame rp p rr -> RIO env (SwapchainResources, rp)
getNext Frame{rp
p
Maybe PresentModeKHR
Word64
(ReleaseKey, InternalState)
(RefCounted, InternalState)
Window
IORef [GPUWork]
SurfaceKHR
Semaphore
SampleCountFlagBits
SwapchainResources
RecycledResources rr
fRecycledResources :: RecycledResources rr
fResources :: (ReleaseKey, InternalState)
fGPUWork :: IORef [GPUWork]
fStageResources :: (RefCounted, InternalState)
fRenderFinishedHostSemaphore :: Semaphore
fPipelines :: p
fRenderpass :: rp
fSwapchainResources :: SwapchainResources
fMSAA :: SampleCountFlagBits
fPresent :: Maybe PresentModeKHR
fSurface :: SurfaceKHR
fWindow :: Window
fIndex :: Word64
$sel:fRecycledResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> RecycledResources resources
$sel:fResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (ReleaseKey, InternalState)
$sel:fGPUWork:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> IORef [GPUWork]
$sel:fRenderFinishedHostSemaphore:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Semaphore
$sel:fPipelines:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> pipelines
$sel:fRenderpass:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> renderpass
$sel:fSwapchainResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
$sel:fMSAA:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SampleCountFlagBits
$sel:fPresent:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Maybe PresentModeKHR
$sel:fStageResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
$sel:fSurface:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SurfaceKHR
$sel:fWindow:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
$sel:fIndex:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
..} = do
if Bool
needsNewSwapchain then do
Extent2D
windowSize <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Window -> IO Extent2D
Window.getExtent2D Window
fWindow
SwapchainResources
newResources <- forall env.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
Maybe PresentModeKHR
-> SampleCountFlagBits
-> Extent2D
-> SwapchainResources
-> RIO env SwapchainResources
recreateSwapchainResources Maybe PresentModeKHR
fPresent SampleCountFlagBits
fMSAA Extent2D
windowSize SwapchainResources
fSwapchainResources
let
formatMatch :: Bool
formatMatch =
SwapchainInfo -> Format
siSurfaceFormat (SwapchainResources -> SwapchainInfo
srInfo SwapchainResources
newResources) forall a. Eq a => a -> a -> Bool
==
SwapchainInfo -> Format
siSurfaceFormat (SwapchainResources -> SwapchainInfo
srInfo SwapchainResources
fSwapchainResources)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
formatMatch do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Swapchain changed format"
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"TODO: Handle swapchain changing formats"
rp
newRenderpass <- forall a env swapchain.
(RenderPass a, HasLogFunc env, HasSwapchain swapchain,
HasVulkan env, MonadResource (RIO env)) =>
swapchain -> a -> RIO env a
updateRenderpass SwapchainResources
newResources rp
fRenderpass
pure
( SwapchainResources
newResources
, rp
newRenderpass
)
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( SwapchainResources
fSwapchainResources
, rp
fRenderpass
)
run
:: ( HasLogFunc env
, HasVulkan env
, MonadResource (RIO env)
)
=> (RecycledResources rr -> IO ())
-> Maybe Int
-> RIO (env, Frame rp p rr) a
-> Frame rp p rr
-> RIO env a
run :: forall env rr rp p a.
(HasLogFunc env, HasVulkan env, MonadResource (RIO env)) =>
(RecycledResources rr -> IO ())
-> Maybe Int
-> RIO (env, Frame rp p rr) a
-> Frame rp p rr
-> RIO env a
run RecycledResources rr -> IO ()
recycle Maybe Int
recyclerWait RIO (env, Frame rp p rr) a
render frame :: Frame rp p rr
frame@Frame{rp
p
Maybe PresentModeKHR
Word64
(ReleaseKey, InternalState)
(RefCounted, InternalState)
Window
IORef [GPUWork]
SurfaceKHR
Semaphore
SampleCountFlagBits
SwapchainResources
RecycledResources rr
fRecycledResources :: RecycledResources rr
fResources :: (ReleaseKey, InternalState)
fGPUWork :: IORef [GPUWork]
fStageResources :: (RefCounted, InternalState)
fRenderFinishedHostSemaphore :: Semaphore
fPipelines :: p
fRenderpass :: rp
fSwapchainResources :: SwapchainResources
fMSAA :: SampleCountFlagBits
fPresent :: Maybe PresentModeKHR
fSurface :: SurfaceKHR
fWindow :: Window
fIndex :: Word64
$sel:fRecycledResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> RecycledResources resources
$sel:fResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (ReleaseKey, InternalState)
$sel:fGPUWork:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> IORef [GPUWork]
$sel:fRenderFinishedHostSemaphore:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Semaphore
$sel:fPipelines:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> pipelines
$sel:fRenderpass:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> renderpass
$sel:fSwapchainResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
$sel:fMSAA:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SampleCountFlagBits
$sel:fPresent:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Maybe PresentModeKHR
$sel:fStageResources:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
$sel:fSurface:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SurfaceKHR
$sel:fWindow:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
$sel:fIndex:Frame :: forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
..} = do
env
env <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO (env
env, Frame rp p rr
frame) RIO (env, Frame rp p rr) a
render forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *) a.
(MonadUnliftIO m, MonadResource m) =>
m a -> m (Async a)
spawn RIO env ()
flush)
where
flush :: RIO env ()
flush = do
Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
[GPUWork]
waits <- forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef [GPUWork]
fGPUWork
let tenSecondsKhr :: Word64
tenSecondsKhr = Word64
10e9
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GPUWork]
waits) do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Maybe Int
recyclerWait
let
waitInfo :: SemaphoreWaitInfo
waitInfo = forall a. Zero a => a
zero
{ $sel:semaphores:SemaphoreWaitInfo :: Vector Semaphore
Vk12.semaphores = forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [GPUWork]
waits)
, $sel:values:SemaphoreWaitInfo :: Vector Word64
Vk12.values = forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [GPUWork]
waits)
}
forall env (m :: * -> *).
(MonadVulkan env m, HasLogFunc env) =>
SemaphoreWaitInfo -> Word64 -> m Result
waitTwice SemaphoreWaitInfo
waitInfo Word64
tenSecondsKhr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Result
Vk.TIMEOUT -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"Time out (10s) waiting for frame to finish on Device"
forall (m :: * -> *) a. MonadThrow m => String -> m a
timeoutError String
"Time out (10s) waiting for frame to finish on Device"
Result
Vk.SUCCESS ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Result
huh ->
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"waitTwice returned " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Result
huh
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. RecycledResources a -> Queues CommandPool
rrQueues RecycledResources rr
fRecycledResources) \CommandPool
commandPool ->
forall (io :: * -> *).
MonadIO io =>
Device -> CommandPool -> CommandPoolResetFlags -> io ()
Vk.resetCommandPool Device
device CommandPool
commandPool CommandPoolResetFlags
Vk.COMMAND_POOL_RESET_RELEASE_RESOURCES_BIT
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RecycledResources rr -> IO ()
recycle RecycledResources rr
fRecycledResources
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release (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 (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
mask \forall a. m a -> m a
_ -> do
forall (io :: * -> *).
MonadIO io =>
Queue -> Vector (SomeStruct SubmitInfo) -> Fence -> io ()
Vk.queueSubmit Queue
q Vector (SomeStruct SubmitInfo)
submits forall a. IsHandle a => a
Vk.NULL_HANDLE
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef [GPUWork]
gpuWork \[GPUWork]
waits ->
( (Semaphore
hostSemaphore, Word64
frameIndex) forall a. a -> [a] -> [a]
: [GPUWork]
waits
, ()
)
initialRecycledResources
:: ( Resource.MonadResource (RIO env)
, HasVulkan env
, HasLogFunc env
)
=> (Queues Vk.CommandPool -> rp -> p -> ResourceT (RIO env) rr)
-> rp
-> p
-> ResourceT (RIO env) (RecycledResources rr)
initialRecycledResources :: forall env rp p rr.
(MonadResource (RIO env), HasVulkan env, HasLogFunc env) =>
(Queues CommandPool -> rp -> p -> ResourceT (RIO env) rr)
-> rp -> p -> ResourceT (RIO env) (RecycledResources rr)
initialRecycledResources Queues CommandPool -> rp -> p -> ResourceT (RIO env) rr
initialRecycledData rp
rps p
pipes = do
Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
(ReleaseKey
_iaKey, Semaphore
rrImageAvailableSemaphore) <- forall (a :: [*]) (io :: * -> *) r.
(Extendss SemaphoreCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> SemaphoreCreateInfo a
-> Maybe AllocationCallbacks
-> (io Semaphore -> (Semaphore -> io ()) -> r)
-> r
Vk.withSemaphore
Device
device
(forall a. Zero a => a
zero forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& SemaphoreType -> Word64 -> SemaphoreTypeCreateInfo
Vk12.SemaphoreTypeCreateInfo SemaphoreType
Vk12.SEMAPHORE_TYPE_BINARY Word64
0 forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ())
forall a. Maybe a
Nothing
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
(ReleaseKey
_rfKey, Semaphore
rrRenderFinishedSemaphore) <- forall (a :: [*]) (io :: * -> *) r.
(Extendss SemaphoreCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> SemaphoreCreateInfo a
-> Maybe AllocationCallbacks
-> (io Semaphore -> (Semaphore -> io ()) -> r)
-> r
Vk.withSemaphore
Device
device
(forall a. Zero a => a
zero forall (a :: [*] -> *) (es :: [*]) (es' :: [*]).
Extensible a =>
a es' -> Chain es -> a es
::& SemaphoreType -> Word64 -> SemaphoreTypeCreateInfo
Vk12.SemaphoreTypeCreateInfo SemaphoreType
Vk12.SEMAPHORE_TYPE_BINARY Word64
0 forall e (es :: [*]). e -> Chain es -> Chain (e : es)
:& ())
forall a. Maybe a
Nothing
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
Queues (QueueFamilyIndex, Queue)
queues <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Queues (QueueFamilyIndex, Queue)
getQueues
Queues CommandPool
rrQueues <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Queues (QueueFamilyIndex, Queue)
queues \(QueueFamilyIndex "image index" ::: Word32
ix, Queue
_queue) -> do
let
commandPoolCI :: CommandPoolCreateInfo
commandPoolCI = Vk.CommandPoolCreateInfo
{ $sel:flags:CommandPoolCreateInfo :: CommandPoolCreateFlags
flags = forall a. Zero a => a
zero
, $sel:queueFamilyIndex:CommandPoolCreateInfo :: "image index" ::: Word32
queueFamilyIndex = "image index" ::: Word32
ix
}
IO ()
cpDebug <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Release time for command pool for queue " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display "image index" ::: Word32
ix
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
ResourceT.register IO ()
cpDebug
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$! forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandPoolCreateInfo
-> Maybe AllocationCallbacks
-> (io CommandPool -> (CommandPool -> io ()) -> r)
-> r
Vk.withCommandPool Device
device CommandPoolCreateInfo
commandPoolCI forall a. Maybe a
Nothing forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
ResourceT.allocate
rr
rrData <- Queues CommandPool -> rp -> p -> ResourceT (RIO env) rr
initialRecycledData Queues CommandPool
rrQueues rp
rps p
pipes
pure RecycledResources{rr
Semaphore
Queues CommandPool
$sel:rrData:RecycledResources :: rr
$sel:rrRenderFinishedSemaphore:RecycledResources :: Semaphore
$sel:rrImageAvailableSemaphore:RecycledResources :: Semaphore
rrData :: rr
rrQueues :: Queues CommandPool
rrRenderFinishedSemaphore :: Semaphore
rrImageAvailableSemaphore :: Semaphore
$sel:rrQueues:RecycledResources :: Queues CommandPool
..}
waitTwice
:: (MonadVulkan env m, HasLogFunc env)
=> Vk12.SemaphoreWaitInfo
-> "timeout" ::: Word64
-> m Vk.Result
waitTwice :: forall env (m :: * -> *).
(MonadVulkan env m, HasLogFunc env) =>
SemaphoreWaitInfo -> Word64 -> m Result
waitTwice SemaphoreWaitInfo
waitInfo Word64
t = do
Device
device <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice
forall (io :: * -> *).
MonadIO io =>
Device -> SemaphoreWaitInfo -> Word64 -> io Result
Vk12.waitSemaphoresSafe Device
device SemaphoreWaitInfo
waitInfo Word64
t forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Result
Vk.TIMEOUT -> do
Result
r <- forall (io :: * -> *).
MonadIO io =>
Device -> SemaphoreWaitInfo -> Word64 -> io Result
Vk12.waitSemaphoresSafe Device
device SemaphoreWaitInfo
waitInfo Word64
1e3
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
[ Utf8Builder
"waiting a second time on " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SemaphoreWaitInfo
waitInfo
, Utf8Builder
" got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Result
r
]
pure Result
r
Result
r ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r
timeoutError :: MonadThrow m => String -> m a
timeoutError :: forall (m :: * -> *) a. MonadThrow m => String -> m a
timeoutError String
message =
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError forall a. Maybe a
Nothing IOErrorType
TimeExpired String
"" String
message forall a. Maybe a
Nothing forall a. Maybe a
Nothing
spawn :: (MonadUnliftIO m, MonadResource m) => m a -> m (Async a)
spawn :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadResource m) =>
m a -> m (Async a)
spawn m a
action = do
IO a
actionIO <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO m a
action
MVar ReleaseKey
kv <- forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
_ -> do
(ReleaseKey
k, Async a
r) <- forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
allocate
(forall (m :: * -> *) a.
MonadUnliftIO m =>
((forall b. m b -> m b) -> m a) -> m (Async a)
asyncWithUnmask \forall b. IO b -> IO b
unmask ->
forall b. IO b -> IO b
unmask forall a b. (a -> b) -> a -> b
$ IO a
actionIO forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (forall (m :: * -> *). MonadIO m => ReleaseKey -> m (Maybe (IO ()))
Resource.unprotect forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar ReleaseKey
kv))
)
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
uninterruptibleCancel
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar ReleaseKey
kv ReleaseKey
k
pure Async a
r