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 GHC.Clock (getMonotonicTimeNSec)
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, optionsMaxFPS)
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
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Stage stack finished"
forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe SwapchainResources
Nothing ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just SwapchainResources
oldSR ->
forall (m :: * -> *). MonadIO m => RefCounted -> m ()
releaseRefCounted (SwapchainResources -> RefCounted
srRelease SwapchainResources
oldSR)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (io :: * -> *). MonadIO io => Device -> io ()
Vk.deviceWaitIdle
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
0.5e6
StackStage Stage rp p rr st
stage : StageStack
rest -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Setting up stage " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (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) <- forall env st a.
StageRIO env (ReleaseKey, st)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
prepareStage (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 <- forall s (m :: * -> *). MonadState s m => m s
get
StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult
runner (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) 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
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Resuming stage " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (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) <- forall env st a.
StageRIO env (ReleaseKey, st)
-> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a)
prepareStage (forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReleaseKey
stKey, st
state))
Maybe SwapchainResources
oldSR <- forall s (m :: * -> *). MonadState s m => m s
get
StageRIO st StageResult
-> StageRIO (Maybe SwapchainResources) StageResult
runner (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) 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
forall s (m :: * -> *). MonadState s m => s -> m ()
put (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 forall a. a -> [a] -> [a]
: StageStack
rest)
StagePush StackStage
frozenStage StackStage
nextStage -> do
case StackStage
frozenStage of
StackStage{} ->
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Restarting stage pushed"
StackStageContinue{} ->
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 forall a. a -> [a] -> [a]
: StackStage
frozenStage forall a. a -> [a] -> [a]
: StageStack
rest)
where
releaseStage :: Utf8Builder -> StageRIO (Maybe SwapchainResources) ()
releaseStage Utf8Builder
label = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
label
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async do
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a. HasVulkan a => a -> Device
getDevice forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (io :: * -> *). MonadIO io => Device -> io ()
Vk.deviceWaitIdle
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
stageRelease
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
label 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 <- 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
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
let
stageApp :: App GlobalHandles st
stageApp = 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
..
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReleaseKey
key, 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
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Starting stage: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
DataRecycler (RecycledResources rr)
recycler <- forall (m :: * -> *) a. MonadIO m => m (DataRecycler a)
DataRecycler.new
Frame rp p rr
startFrame <- 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 (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, Options
$sel:ghOptions:GlobalHandles :: GlobalHandles -> Options
ghOptions :: Options
ghOptions} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall env st. App env st -> env
appEnv
Bool
quit <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Window -> IO Bool
GLFW.windowShouldClose Window
ghWindow
if Bool
quit then do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Forcing stage unwind for " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
pure
( forall renderpass pipelines resources.
Frame renderpass pipelines resources -> SwapchainResources
Frame.fSwapchainResources Frame rp p rr
startFrame
, StageAction
StageDone
)
else do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Entering stage loop: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
Double
startTime <- forall (m :: * -> *). MonadIO m => m Double
getMonotonicTime
(Frame rp p rr
finalFrame, StageAction
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 ->
forall f st.
(f -> StageRIO st (LoopAction f))
-> f -> StageRIO st (f, StageAction)
stageLoop (forall rp p rr st.
RenderPass rp =>
ReleaseKey
-> Stage rp p rr st
-> DataRecycler (RecycledResources rr)
-> Maybe Int
-> Frame rp p rr
-> StageRIO st (LoopAction (Frame rp p rr))
step ReleaseKey
stKey Stage rp p rr st
stage DataRecycler (RecycledResources rr)
recycler (Options -> Maybe Int
optionsMaxFPS Options
ghOptions)) Frame rp p rr
startFrame
Double
endTime <- forall (m :: * -> *). MonadIO m => m Double
getMonotonicTime
let
frames :: Word64
frames = forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Word64
Frame.fIndex Frame rp p rr
finalFrame
seconds :: Double
seconds = Double
endTime forall a. Num a => a -> a -> a
- Double
startTime
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Stage finished: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
sTitle
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Running time: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Double
seconds
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Average FPS: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
frames forall a. Fractional a => a -> a -> a
/ Double
seconds)
forall (m :: * -> *). MonadIO m => RefCounted -> m ()
releaseRefCounted forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (forall renderpass pipelines resources.
Frame renderpass pipelines resources -> (RefCounted, InternalState)
Frame.fStageResources Frame rp p rr
finalFrame)
pure
( 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)
-> Maybe Int
-> 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)
-> Maybe Int
-> 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
..} Maybe Int
maxFPSM Frame rp p rr
frame = do
Word64
startTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
getMonotonicTimeNSec
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
GLFW.pollEvents
Bool
quit <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Window -> IO Bool
GLFW.windowShouldClose (forall renderpass pipelines resources.
Frame renderpass pipelines resources -> Window
Frame.fWindow Frame rp p rr
frame)
if Bool
quit then
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall f. LoopAction f
LoopQuit
else
forall rs. StageRIO rs (Maybe NextStage)
getNextStage forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe NextStage
Nothing -> do
Bool
needsNewSwapchain <- forall (f :: * -> *). MonadUnliftIO f => f () -> f Bool
threwSwapchainError do
Engine.GlobalHandles{Options
ghOptions :: Options
$sel:ghOptions:GlobalHandles :: GlobalHandles -> Options
ghOptions} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall env st. App env st -> env
appEnv
let recyclerWait :: Maybe Int
recyclerWait = Options -> Maybe Int
optionsRecyclerWait Options
ghOptions
st
rs <- forall s (m :: * -> *). MonadState s m => m s
get
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 (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 <- 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
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Int
maxFPSM \Int
maxFPS -> do
Word64
endTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Word64
getMonotonicTimeNSec
let elapsedUS :: Int
elapsedUS = (forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ Word64
endTime forall a. Num a => a -> a -> a
- Word64
startTime) forall a. Integral a => a -> a -> a
`div` Int
1e3 :: Int
fpsCapUS :: Int
fpsCapUS = Int
1e6 forall a. Integral a => a -> a -> a
`div` Int
maxFPS
waitUS :: Int
waitUS = Int
fpsCapUS forall a. Num a => a -> a -> a
- forall a. Ord a => a -> a -> a
min Int
fpsCapUS Int
elapsedUS
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
waitUS
pure $ forall f. f -> LoopAction f
LoopNextFrame Frame rp p rr
nextFrame
Just NextStage
Finish ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall f. LoopAction f
LoopQuit
Just (Replace StackStage
nextStage) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall f. f -> StackStage -> LoopAction f
LoopReplaceStage Frame rp p rr
frame StackStage
nextStage
Just (PushRestart StackStage
nextStage) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall f. f -> StackStage -> StackStage -> LoopAction f
LoopPushStage Frame rp p rr
frame (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 <- 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 $ 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 <- forall s (m :: * -> *). MonadState s m => m s
get
pure $ 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
LoopNextFrame f
nextFrame ->
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 ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
current, StageAction
StageDone)
LoopReplaceStage f
lastFrame StackStage
nextStage ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
lastFrame, StackStage -> StageAction
StageReplace StackStage
nextStage)
LoopPushStage f
lastFrame StackStage
frozenStage StackStage
nextStage ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f
lastFrame, StackStage -> StackStage -> StageAction
StagePush StackStage
frozenStage StackStage
nextStage)