module Engine.Run
( runStack
, run
, step
) where
import RIO
import Graphics.UI.GLFW qualified as GLFW
import RIO.App (App(..), appEnv)
import RIO.State (get, put)
import UnliftIO.Resource (ReleaseKey, release)
import Vulkan.Core10 qualified as Vk
import Engine.DataRecycler (DataRecycler(..))
import Engine.DataRecycler qualified as DataRecycler
import Engine.Frame qualified as Frame
import Engine.Render (renderFrame)
import Engine.StageSwitch (getNextStage)
import Engine.Types (Frame, NextStage(..), RecycledResources, StageStack, StackStage(..), Stage(..), StageRIO)
import Engine.Types qualified as Engine
import Engine.Types.Options (optionsRecyclerWait)
import Engine.Types.RefCounted (releaseRefCounted)
import Engine.Vulkan.Swapchain (SwapchainResources(srRelease), threwSwapchainError)
import Engine.Vulkan.Types (RenderPass, getDevice)
runStack :: StageStack -> StageRIO (Maybe SwapchainResources) ()
runStack :: StageStack -> StageRIO (Maybe SwapchainResources) ()
runStack = \case
[] -> do
Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Stage stack finished"
RIO
(App GlobalHandles (Maybe SwapchainResources))
(Maybe SwapchainResources)
forall s (m :: * -> *). MonadState s m => m s
get RIO
(App GlobalHandles (Maybe SwapchainResources))
(Maybe SwapchainResources)
-> (Maybe SwapchainResources
-> StageRIO (Maybe SwapchainResources) ())
-> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe SwapchainResources
Nothing ->
() -> StageRIO (Maybe SwapchainResources) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just SwapchainResources
oldSR ->
RefCounted -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *). MonadIO m => RefCounted -> m ()
releaseRefCounted (SwapchainResources -> RefCounted
srRelease SwapchainResources
oldSR)
(App GlobalHandles (Maybe SwapchainResources) -> Device)
-> RIO (App GlobalHandles (Maybe SwapchainResources)) Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks App GlobalHandles (Maybe SwapchainResources) -> Device
forall a. HasVulkan a => a -> Device
getDevice RIO (App GlobalHandles (Maybe SwapchainResources)) Device
-> (Device -> StageRIO (Maybe SwapchainResources) ())
-> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Device -> StageRIO (Maybe SwapchainResources) ()
forall (io :: * -> *). MonadIO io => Device -> io ()
Vk.deviceWaitIdle
Int -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
0.5e6
StackStage Stage rp p rr st
stage : StageStack
rest -> do
Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO (Maybe SwapchainResources) ())
-> Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Setting up stage " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Stage rp p rr st -> Text
forall rp p rr st. Stage rp p rr st -> Text
sTitle Stage rp p rr st
stage)
(ReleaseKey
stageRelease, StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult
runner) <- StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
-> StageRIO
(Maybe SwapchainResources)
(ReleaseKey,
StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult)
forall env st a.
StageRIO env (ReleaseKey, st)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
prepareStage (Stage rp p rr st
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
forall rp p rr st.
Stage rp p rr st
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
sInitialRS Stage rp p rr st
stage)
Maybe SwapchainResources
oldSR <- RIO
(App GlobalHandles (Maybe SwapchainResources))
(Maybe SwapchainResources)
forall s (m :: * -> *). MonadState s m => m s
get
StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult
runner (Maybe SwapchainResources
-> ReleaseKey -> Stage rp p rr st -> StageRIO st StageResult
forall rp p rr st.
RenderPass rp =>
Maybe SwapchainResources
-> ReleaseKey -> Stage rp p rr st -> StageRIO st StageResult
run Maybe SwapchainResources
oldSR ReleaseKey
stageRelease Stage rp p rr st
stage) StageRIO (Maybe SwapchainResources) StageResult
-> (StageResult -> StageRIO (Maybe SwapchainResources) ())
-> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReleaseKey
-> StageStack
-> StageResult
-> StageRIO (Maybe SwapchainResources) ()
proceed ReleaseKey
stageRelease StageStack
rest
StackStageContinue ReleaseKey
stKey st
state Stage rp p rr st
stage : StageStack
rest -> do
Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO (Maybe SwapchainResources) ())
-> Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Resuming stage " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Stage rp p rr st -> Text
forall rp p rr st. Stage rp p rr st -> Text
sTitle Stage rp p rr st
stage)
(ReleaseKey
stageRelease, StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult
runner) <- StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
-> StageRIO
(Maybe SwapchainResources)
(ReleaseKey,
StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult)
forall env st a.
StageRIO env (ReleaseKey, st)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
prepareStage ((ReleaseKey, st)
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReleaseKey
stKey, st
state))
Maybe SwapchainResources
oldSR <- RIO
(App GlobalHandles (Maybe SwapchainResources))
(Maybe SwapchainResources)
forall s (m :: * -> *). MonadState s m => m s
get
StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult
runner (Maybe SwapchainResources
-> ReleaseKey -> Stage rp p rr st -> StageRIO st StageResult
forall rp p rr st.
RenderPass rp =>
Maybe SwapchainResources
-> ReleaseKey -> Stage rp p rr st -> StageRIO st StageResult
run Maybe SwapchainResources
oldSR ReleaseKey
stageRelease Stage rp p rr st
stage) StageRIO (Maybe SwapchainResources) StageResult
-> (StageResult -> StageRIO (Maybe SwapchainResources) ())
-> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReleaseKey
-> StageStack
-> StageResult
-> StageRIO (Maybe SwapchainResources) ()
proceed ReleaseKey
stageRelease StageStack
rest
type StageResult = (SwapchainResources, StageAction)
proceed :: ReleaseKey -> StageStack -> StageResult -> StageRIO (Maybe SwapchainResources) ()
proceed :: ReleaseKey
-> StageStack
-> StageResult
-> StageRIO (Maybe SwapchainResources) ()
proceed ReleaseKey
stageRelease StageStack
rest (SwapchainResources
oldSR, StageAction
stageAction) = do
Maybe SwapchainResources -> StageRIO (Maybe SwapchainResources) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (SwapchainResources -> Maybe SwapchainResources
forall a. a -> Maybe a
Just SwapchainResources
oldSR)
case StageAction
stageAction of
StageAction
StageDone -> do
Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
releaseStage Utf8Builder
"Stage done"
StageStack -> StageRIO (Maybe SwapchainResources) ()
runStack StageStack
rest
StageReplace StackStage
nextStage -> do
Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
releaseStage Utf8Builder
"Stage replaced"
StageStack -> StageRIO (Maybe SwapchainResources) ()
runStack (StackStage
nextStage StackStage -> StageStack -> StageStack
forall a. a -> [a] -> [a]
: StageStack
rest)
StagePush StackStage
frozenStage StackStage
nextStage -> do
case StackStage
frozenStage of
StackStage{} ->
Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Restarting stage pushed"
StackStageContinue{} ->
Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Frozen stage pushed"
StageStack -> StageRIO (Maybe SwapchainResources) ()
runStack (StackStage
nextStage StackStage -> StageStack -> StageStack
forall a. a -> [a] -> [a]
: StackStage
frozenStage StackStage -> StageStack -> StageStack
forall a. a -> [a] -> [a]
: StageStack
rest)
where
releaseStage :: Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
releaseStage Utf8Builder
label = do
Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
label
RIO (App GlobalHandles (Maybe SwapchainResources)) (Async ())
-> StageRIO (Maybe SwapchainResources) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO (App GlobalHandles (Maybe SwapchainResources)) (Async ())
-> StageRIO (Maybe SwapchainResources) ())
-> RIO (App GlobalHandles (Maybe SwapchainResources)) (Async ())
-> StageRIO (Maybe SwapchainResources) ()
forall a b. (a -> b) -> a -> b
$! StageRIO (Maybe SwapchainResources) ()
-> RIO (App GlobalHandles (Maybe SwapchainResources)) (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async do
(App GlobalHandles (Maybe SwapchainResources) -> Device)
-> RIO (App GlobalHandles (Maybe SwapchainResources)) Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks App GlobalHandles (Maybe SwapchainResources) -> Device
forall a. HasVulkan a => a -> Device
getDevice RIO (App GlobalHandles (Maybe SwapchainResources)) Device
-> (Device -> StageRIO (Maybe SwapchainResources) ())
-> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Device -> StageRIO (Maybe SwapchainResources) ()
forall (io :: * -> *). MonadIO io => Device -> io ()
Vk.deviceWaitIdle
ReleaseKey -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
stageRelease
Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> StageRIO (Maybe SwapchainResources) ())
-> Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
label Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", released"
prepareStage
:: StageRIO env (ReleaseKey, st)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
prepareStage :: forall env st a.
StageRIO env (ReleaseKey, st)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
prepareStage StageRIO env (ReleaseKey, st)
initialRS = do
(ReleaseKey
key, st
rs) <- StageRIO env (ReleaseKey, st)
initialRS
SomeRef st
freshStateVar <- st -> RIO (App GlobalHandles env) (SomeRef st)
forall (m :: * -> *) a. MonadIO m => a -> m (SomeRef a)
newSomeRef st
rs
App{InternalState
ProcessContext
SomeRef env
LogFunc
GlobalHandles
appLogFunc :: forall env st. App env st -> LogFunc
appProcessContext :: forall env st. App env st -> ProcessContext
appResources :: forall env st. App env st -> InternalState
appState :: forall env st. App env st -> SomeRef st
appState :: SomeRef env
appEnv :: GlobalHandles
appResources :: InternalState
appProcessContext :: ProcessContext
appLogFunc :: LogFunc
appEnv :: forall env st. App env st -> env
..} <- RIO (App GlobalHandles env) (App GlobalHandles env)
forall r (m :: * -> *). MonadReader r m => m r
ask
let
stageApp :: App GlobalHandles st
stageApp = App :: forall env st.
LogFunc
-> ProcessContext
-> InternalState
-> env
-> SomeRef st
-> App env st
App
{ appState :: SomeRef st
appState = SomeRef st
freshStateVar
, InternalState
ProcessContext
LogFunc
GlobalHandles
appLogFunc :: LogFunc
appProcessContext :: ProcessContext
appResources :: InternalState
appEnv :: GlobalHandles
appResources :: InternalState
appProcessContext :: ProcessContext
appLogFunc :: LogFunc
appEnv :: GlobalHandles
..
}
(ReleaseKey, StageRIO st a -> StageRIO env a)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReleaseKey
key, App GlobalHandles st -> StageRIO st a -> StageRIO env a
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO App GlobalHandles st
stageApp)
run
:: RenderPass rp
=> Maybe SwapchainResources
-> ReleaseKey
-> Stage rp p rr st
-> StageRIO st StageResult
run :: forall rp p rr st.
RenderPass rp =>
Maybe SwapchainResources
-> ReleaseKey -> Stage rp p rr st -> StageRIO st StageResult
run Maybe SwapchainResources
oldSR ReleaseKey
stKey stage :: Stage rp p rr st
stage@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: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
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
$sel:sInitialRS:Stage :: forall rp p rr st.
Stage rp p rr st
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
$sel:sTitle:Stage :: forall rp p rr st. Stage rp p rr st -> Text
..} = do
Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO st ()) -> Utf8Builder -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Starting stage: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
sTitle
DataRecycler (RecycledResources rr)
recycler <- RIO (App GlobalHandles st) (DataRecycler (RecycledResources rr))
forall (m :: * -> *) a. MonadIO m => m (DataRecycler a)
DataRecycler.new
Frame rp p rr
startFrame <- Maybe SwapchainResources
-> DumpResource (RecycledResources rr)
-> Stage rp p rr st
-> StageRIO st (Frame rp p rr)
forall rr rp p st.
Maybe SwapchainResources
-> DumpResource (RecycledResources rr)
-> Stage rp p rr st
-> StageRIO st (Frame rp p rr)
Frame.initial Maybe SwapchainResources
oldSR (DataRecycler (RecycledResources rr)
-> DumpResource (RecycledResources rr)
forall a. DataRecycler a -> DumpResource a
drDump DataRecycler (RecycledResources rr)
recycler) Stage rp p rr st
stage
Engine.GlobalHandles{Window
$sel:ghWindow:GlobalHandles :: GlobalHandles -> Window
ghWindow :: Window
ghWindow} <- (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
Bool
quit <- IO Bool -> RIO (App GlobalHandles st) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO (App GlobalHandles st) Bool)
-> IO Bool -> RIO (App GlobalHandles st) Bool
forall a b. (a -> b) -> a -> b
$ Window -> IO Bool
GLFW.windowShouldClose Window
ghWindow
if Bool
quit then do
Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> StageRIO st ()) -> Utf8Builder -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Forcing stage unwind for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
sTitle
pure
( Frame rp p rr -> SwapchainResources
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
Frame.fSwapchainResources Frame rp p rr
startFrame
, StageAction
StageDone
)
else do
Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO st ()) -> Utf8Builder -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Entering stage loop: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
sTitle
Double
startTime <- RIO (App GlobalHandles st) Double
forall (m :: * -> *). MonadIO m => m Double
getMonotonicTime
(Frame rp p rr
finalFrame, StageAction
stageAction) <- StageRIO st a
-> (a -> StageRIO st ())
-> (a -> RIO (App GlobalHandles st) (Frame rp p rr, StageAction))
-> RIO (App GlobalHandles st) (Frame rp p rr, StageAction)
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket StageRIO st a
sBeforeLoop a -> StageRIO st ()
sAfterLoop \a
_stagePrivates ->
(Frame rp p rr -> StageRIO st (LoopAction (Frame rp p rr)))
-> Frame rp p rr
-> RIO (App GlobalHandles st) (Frame rp p rr, StageAction)
forall f st.
(f -> StageRIO st (LoopAction f))
-> f -> StageRIO st (f, StageAction)
stageLoop (ReleaseKey
-> Stage rp p rr st
-> DataRecycler (RecycledResources rr)
-> Frame rp p rr
-> StageRIO st (LoopAction (Frame rp p rr))
forall rp p rr st.
RenderPass rp =>
ReleaseKey
-> Stage rp p rr st
-> DataRecycler (RecycledResources rr)
-> Frame rp p rr
-> StageRIO st (LoopAction (Frame rp p rr))
step ReleaseKey
stKey Stage rp p rr st
stage DataRecycler (RecycledResources rr)
recycler) Frame rp p rr
startFrame
Double
endTime <- RIO (App GlobalHandles st) Double
forall (m :: * -> *). MonadIO m => m Double
getMonotonicTime
let
frames :: Word64
frames = Frame rp p rr -> Word64
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
Frame.fIndex Frame rp p rr
finalFrame
seconds :: Double
seconds = Double
endTime Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
startTime
Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO st ()) -> Utf8Builder -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Stage finished: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
sTitle
Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO st ()) -> Utf8Builder -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Running time: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Double -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Double
seconds
Utf8Builder -> StageRIO st ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> StageRIO st ()) -> Utf8Builder -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Average FPS: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Double -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
frames Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
seconds)
RefCounted -> StageRIO st ()
forall (m :: * -> *). MonadIO m => RefCounted -> m ()
releaseRefCounted (RefCounted -> StageRIO st ()) -> RefCounted -> StageRIO st ()
forall a b. (a -> b) -> a -> b
$ (RefCounted, InternalState) -> RefCounted
forall a b. (a, b) -> a
fst (Frame rp p rr -> (RefCounted, InternalState)
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
Frame.fStageResources Frame rp p rr
finalFrame)
pure
( Frame rp p rr -> SwapchainResources
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
Frame.fSwapchainResources Frame rp p rr
finalFrame
, StageAction
stageAction
)
step
:: RenderPass rp
=> ReleaseKey
-> Stage rp p rr st
-> DataRecycler (RecycledResources rr)
-> Frame rp p rr
-> StageRIO st (LoopAction (Frame rp p rr))
step :: forall rp p rr st.
RenderPass rp =>
ReleaseKey
-> Stage rp p rr st
-> DataRecycler (RecycledResources rr)
-> Frame rp p rr
-> StageRIO st (LoopAction (Frame rp p rr))
step ReleaseKey
stKey stage :: Stage rp p rr st
stage@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
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
$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: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:sInitialRS:Stage :: forall rp p rr st.
Stage rp p rr st
-> StageRIO (Maybe SwapchainResources) (ReleaseKey, st)
$sel:sTitle:Stage :: forall rp p rr st. Stage rp p rr st -> Text
..} DataRecycler{WaitResource (RecycledResources rr)
DumpResource (RecycledResources rr)
$sel:drWait:DataRecycler :: forall a. DataRecycler a -> WaitResource a
drWait :: WaitResource (RecycledResources rr)
drDump :: DumpResource (RecycledResources rr)
$sel:drDump:DataRecycler :: forall a. DataRecycler a -> DumpResource a
..} Frame rp p rr
frame = do
IO () -> StageRIO st ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
GLFW.pollEvents
Bool
quit <- IO Bool -> RIO (App GlobalHandles st) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO (App GlobalHandles st) Bool)
-> IO Bool -> RIO (App GlobalHandles st) Bool
forall a b. (a -> b) -> a -> b
$ Window -> IO Bool
GLFW.windowShouldClose (Frame rp p rr -> Window
forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
Frame.fWindow Frame rp p rr
frame)
if Bool
quit then
LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr))
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopAction (Frame rp p rr)
forall f. LoopAction f
LoopQuit
else
StageRIO st (Maybe NextStage)
forall rs. StageRIO rs (Maybe NextStage)
getNextStage StageRIO st (Maybe NextStage)
-> (Maybe NextStage -> StageRIO st (LoopAction (Frame rp p rr)))
-> StageRIO st (LoopAction (Frame rp p rr))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe NextStage
Nothing -> do
Bool
needsNewSwapchain <- StageRIO st () -> RIO (App GlobalHandles st) Bool
forall (f :: * -> *). MonadUnliftIO f => f () -> f Bool
threwSwapchainError do
Engine.GlobalHandles{Options
$sel:ghOptions:GlobalHandles :: GlobalHandles -> Options
ghOptions :: Options
ghOptions} <- (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 recyclerWait :: Maybe Int
recyclerWait = Options -> Maybe Int
optionsRecyclerWait Options
ghOptions
st
rs <- RIO (App GlobalHandles st) st
forall s (m :: * -> *). MonadState s m => m s
get
DumpResource (RecycledResources rr)
-> Maybe Int
-> StageFrameRIO rp p rr st ()
-> Frame rp p rr
-> StageRIO st ()
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
Frame.run DumpResource (RecycledResources rr)
drDump Maybe Int
recyclerWait ((rr -> StageFrameRIO rp p rr st ())
-> (CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ())
-> StageFrameRIO rp p rr st ()
forall rp rr p st.
RenderPass rp =>
(rr -> StageFrameRIO rp p rr st ())
-> (CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ())
-> StageFrameRIO rp p rr st ()
renderFrame (st -> rr -> StageFrameRIO rp p rr st ()
sUpdateBuffers st
rs) CommandBuffer
-> rr -> ("image index" ::: Word32) -> StageFrameRIO rp p rr st ()
sRecordCommands) Frame rp p rr
frame
Frame rp p rr
nextFrame <- WaitResource (RecycledResources rr)
-> Frame rp p rr
-> Bool
-> RIO (App GlobalHandles st) (Frame rp p rr)
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)
Frame.advance WaitResource (RecycledResources rr)
drWait Frame rp p rr
frame Bool
needsNewSwapchain
pure $ Frame rp p rr -> LoopAction (Frame rp p rr)
forall f. f -> LoopAction f
LoopNextFrame Frame rp p rr
nextFrame
Just NextStage
Finish ->
LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr))
forall (f :: * -> *) a. Applicative f => a -> f a
pure LoopAction (Frame rp p rr)
forall f. LoopAction f
LoopQuit
Just (Replace StackStage
nextStage) ->
LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr)))
-> LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr))
forall a b. (a -> b) -> a -> b
$ Frame rp p rr -> StackStage -> LoopAction (Frame rp p rr)
forall f. f -> StackStage -> LoopAction f
LoopReplaceStage Frame rp p rr
frame StackStage
nextStage
Just (PushRestart StackStage
nextStage) ->
LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr)))
-> LoopAction (Frame rp p rr)
-> StageRIO st (LoopAction (Frame rp p rr))
forall a b. (a -> b) -> a -> b
$ Frame rp p rr
-> StackStage -> StackStage -> LoopAction (Frame rp p rr)
forall f. f -> StackStage -> StackStage -> LoopAction f
LoopPushStage Frame rp p rr
frame (Stage rp p rr st -> StackStage
forall rp p rr st. RenderPass rp => Stage rp p rr st -> StackStage
StackStage Stage rp p rr st
stage) StackStage
nextStage
Just (PushFreeze StackStage
nextStage) -> do
StackStage
frozen <- ReleaseKey -> Stage rp p rr st -> StageRIO st StackStage
forall rp p rr st.
RenderPass rp =>
ReleaseKey -> Stage rp p rr st -> StageRIO st StackStage
freeze ReleaseKey
stKey Stage rp p rr st
stage
pure $ Frame rp p rr
-> StackStage -> StackStage -> LoopAction (Frame rp p rr)
forall f. f -> StackStage -> StackStage -> LoopAction f
LoopPushStage Frame rp p rr
frame StackStage
frozen StackStage
nextStage
freeze :: RenderPass rp => ReleaseKey -> Stage rp p rr st -> StageRIO st StackStage
freeze :: forall rp p rr st.
RenderPass rp =>
ReleaseKey -> Stage rp p rr st -> StageRIO st StackStage
freeze ReleaseKey
stKey Stage rp p rr st
stage = do
st
st <- RIO (App GlobalHandles st) st
forall s (m :: * -> *). MonadState s m => m s
get
pure $ ReleaseKey -> st -> Stage rp p rr st -> StackStage
forall rp p rr st.
RenderPass rp =>
ReleaseKey -> st -> Stage rp p rr st -> StackStage
StackStageContinue ReleaseKey
stKey st
st Stage rp p rr st
stage
data StageAction
= StageReplace StackStage
| StagePush StackStage StackStage
| StageDone
data LoopAction f
= LoopNextFrame f
| LoopReplaceStage f StackStage
| LoopPushStage f StackStage StackStage
| LoopQuit
{-# INLINE stageLoop #-}
stageLoop :: (f -> StageRIO st (LoopAction f)) -> f -> StageRIO st (f, StageAction)
stageLoop :: forall f st.
(f -> StageRIO st (LoopAction f))
-> f -> StageRIO st (f, StageAction)
stageLoop f -> StageRIO st (LoopAction f)
action f
current =
f -> StageRIO st (LoopAction f)
action f
current StageRIO st (LoopAction f)
-> (LoopAction f -> RIO (App GlobalHandles st) (f, StageAction))
-> RIO (App GlobalHandles st) (f, StageAction)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
LoopNextFrame f
nextFrame ->
(f -> StageRIO st (LoopAction f))
-> f -> RIO (App GlobalHandles st) (f, StageAction)
forall f st.
(f -> StageRIO st (LoopAction f))
-> f -> StageRIO st (f, StageAction)
stageLoop f -> StageRIO st (LoopAction f)
action f
nextFrame
LoopAction f
LoopQuit ->
(f, StageAction) -> RIO (App GlobalHandles st) (f, StageAction)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
current, StageAction
StageDone)
LoopReplaceStage f
lastFrame StackStage
nextStage ->
(f, StageAction) -> RIO (App GlobalHandles st) (f, StageAction)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
lastFrame, StackStage -> StageAction
StageReplace StackStage
nextStage)
LoopPushStage f
lastFrame StackStage
frozenStage StackStage
nextStage ->
(f, StageAction) -> RIO (App GlobalHandles st) (f, StageAction)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
lastFrame, StackStage -> StackStage -> StageAction
StagePush StackStage
frozenStage StackStage
nextStage)