diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for keid-core + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright IC Rainbow (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# Keid Engine Core diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/keid-core.cabal b/keid-core.cabal new file mode 100644 --- /dev/null +++ b/keid-core.cabal @@ -0,0 +1,168 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: keid-core +version: 0.1.0.0 +synopsis: Core parts of Keid engine. +category: Game Engine +author: IC Rainbow +maintainer: keid@aenor.ru +copyright: 2021 IC Rainbow +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://gitlab.com/keid/engine + +library + exposed-modules: + Engine.App + Engine.Camera + Engine.DataRecycler + Engine.Events + Engine.Events.CursorPos + Engine.Events.MouseButton + Engine.Events.Sink + Engine.Frame + Engine.Render + Engine.Run + Engine.Setup + Engine.Setup.Device + Engine.Setup.Window + Engine.Stage.Bootstrap.Setup + Engine.Stage.Bootstrap.Types + Engine.StageSwitch + Engine.Types + Engine.Types.Options + Engine.Types.RefCounted + Engine.UI.Layout + Engine.Vulkan.DescSets + Engine.Vulkan.Pipeline + Engine.Vulkan.Swapchain + Engine.Vulkan.Types + Engine.Window.CursorPos + Engine.Window.Drop + Engine.Window.Key + Engine.Window.MouseButton + Engine.Window.Scroll + Engine.Worker + Render.Code + Render.Code.Noise + Render.Draw + Render.Samplers + Resource.Buffer + Resource.Collection + Resource.Combined.Textures + Resource.CommandBuffer + Resource.Compressed.Zstd + Resource.DescriptorSet + Resource.Image + Resource.Mesh.Codec + Resource.Mesh.Types + Resource.Mesh.Utils + Resource.Model + Resource.Static + Resource.Texture + Resource.Texture.Ktx1 + other-modules: + Paths_keid_core + hs-source-dirs: + src + default-extensions: + NoImplicitPrelude + ApplicativeDo + BangPatterns + BinaryLiterals + BlockArguments + ConstrainedClassMethods + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyCase + EmptyDataDeriving + ExistentialQuantification + ExplicitForAll + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + HexFloatLiterals + ImportQualifiedPost + InstanceSigs + KindSignatures + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + NamedFieldPuns + NamedWildCards + NumDecimals + NumericUnderscores + OverloadedStrings + PatternSynonyms + PostfixOperators + QuantifiedConstraints + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + UnicodeSyntax + ViewPatterns + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + build-depends: + GLFW-b + , StateVar + , VulkanMemoryAllocator + , adjunctions + , base >=4.7 && <5 + , binary + , bytestring + , cryptohash-md5 + , derive-storable + , derive-storable-plugin + , distributive + , foldl + , geomancy + , ktx-codec + , neat-interpolation + , optparse-applicative + , optparse-simple + , resourcet + , rio >=0.1.12.0 + , rio-app + , tagged + , template-haskell + , text + , transformers + , unagi-chan + , unliftio + , vector + , vulkan + , vulkan-utils + , zstd + default-language: Haskell2010 diff --git a/src/Engine/App.hs b/src/Engine/App.hs new file mode 100644 --- /dev/null +++ b/src/Engine/App.hs @@ -0,0 +1,23 @@ +module Engine.App + ( engineMain + , engineMainWith + ) where + +import RIO + +import RIO.App (appMain) +import Engine.Run (runStack) +import Engine.Setup (setup) +import Engine.Types qualified as Engine +import Engine.Types.Options (Options(..), getOptions) +import Engine.Stage.Bootstrap.Setup qualified as Bootstrap + +engineMain :: Engine.StackStage -> IO () +engineMain initialStage = engineMainWith (\() -> initialStage) (pure ()) + +engineMainWith :: (a -> Engine.StackStage) -> Engine.StageSetupRIO a -> IO () +engineMainWith handoff action = + appMain getOptions optionsVerbose setup $ runStack + [ -- XXX: run swapchain bootstrap and replace with next stage + Bootstrap.stackStage handoff action + ] diff --git a/src/Engine/Camera.hs b/src/Engine/Camera.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Camera.hs @@ -0,0 +1,94 @@ +module Engine.Camera where + +import RIO + +import Geomancy (Transform(..), Vec3, vec3) +import Geomancy.Transform qualified as Transform +import Geomancy.Quaternion qualified as Quaternion +import Geomancy.Vec3 qualified as Vec3 +import Geomancy.Vulkan.Projection qualified as Projection +import Geomancy.Vulkan.View qualified as View +import Vulkan.Core10 qualified as Vk + +import Engine.Worker qualified as Worker + +-- * Projection + +data Projection = Projection + { projectionPerspective :: Transform + , projectionOrthoUI :: Transform + } + deriving (Show) + +instance Semigroup Projection where + _a <> b = Projection + { projectionPerspective = projectionPerspective b + , projectionOrthoUI = projectionOrthoUI b + } + +instance Monoid Projection where + mempty = Projection mempty mempty + +type ProjectionProcess = Worker.Cell ProjectionInput Projection + +data ProjectionInput = ProjectionInput + { projectionFovRads :: Float + , projectionScreen :: Vk.Extent2D + } + deriving (Show) + +mkProjection :: ProjectionInput -> Projection +mkProjection ProjectionInput{..} = Projection{..} + where + -- BUG: infinitePerspective gives huge clipping and effective FoV is different + -- projectionPerspective = Projection.infinitePerspective projectionFovRads width height + projectionPerspective = Projection.perspective projectionFovRads (1/2048) 16384 width height + + projectionOrthoUI = Projection.orthoOffCenter 0 1 width height + + Vk.Extent2D{width, height} = projectionScreen + +-- * View + +data View = View + { viewTransform :: Transform + , viewTransformInv :: Transform + , viewPosition :: Vec3 + , viewDirection :: Vec3 + } + deriving (Show) + +type ViewProcess = Worker.Cell ViewOrbitalInput View + +-- | Camera orbiting its target +data ViewOrbitalInput = ViewOrbitalInput + { orbitAzimuth :: Float + , orbitAscent :: Float + , orbitDistance :: Float + , orbitScale :: Float + , orbitTarget :: Vec3 + } + deriving (Show) + +mkViewOrbital :: Vec3 -> ViewOrbitalInput -> View +mkViewOrbital cameraTarget ViewOrbitalInput{..} = View{..} + where + viewTransform = View.lookAt viewPosition cameraTarget axisUp + viewTransformInv = Transform.inverse viewTransform + + viewPosition = + orbitTarget + + Quaternion.rotate + ( Quaternion.axisAngle axisUp orbitAzimuth * + Quaternion.axisAngle axisRight orbitAscent + ) + (vec3 0 0 $ orbitDistance * orbitScale) + + viewDirection = Vec3.normalize $ cameraTarget - viewPosition + + axisUp = vec3 0 (-1) 0 + axisRight = vec3 1 0 0 + +{-# INLINE mkViewOrbital_ #-} +mkViewOrbital_ :: ViewOrbitalInput -> View +mkViewOrbital_ voi = mkViewOrbital (orbitTarget voi) voi diff --git a/src/Engine/DataRecycler.hs b/src/Engine/DataRecycler.hs new file mode 100644 --- /dev/null +++ b/src/Engine/DataRecycler.hs @@ -0,0 +1,34 @@ +module Engine.DataRecycler where + +import RIO + +import Control.Concurrent.Chan.Unagi qualified as Unagi + +data DataRecycler a = DataRecycler + { drDump :: DumpResource a + {- ^ + Filled with resources which aren't destroyed after finishing a frame, + but instead are used by another frame which executes after that one is + retired, (taken from ghRecycleOut) + + Make sure not to pass any resources which were created with a frame-only + scope however! + -} + , drWait :: WaitResource a + -- ^ The resources of prior frames waiting to be taken + } + +type DumpResource a = a -> IO () + +type WaitResource a = IO (Either (IO a) a) + +new :: MonadIO m => m (DataRecycler a) +new = do + (recycleWrite, recycleRead) <- liftIO Unagi.newChan + pure DataRecycler + { drDump = Unagi.writeChan recycleWrite + , drWait = do + (tryOp, blockOp) <- Unagi.tryReadChan recycleRead + res <- Unagi.tryRead tryOp + pure $ maybe (Left blockOp) Right res + } diff --git a/src/Engine/Events.hs b/src/Engine/Events.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Events.hs @@ -0,0 +1,32 @@ +module Engine.Events + ( Sink(..) + , spawn + , registerMany + ) where + +import RIO + +import UnliftIO.Resource (ReleaseKey) +import UnliftIO.Resource qualified as Resource + +import Engine.Events.Sink (Sink) +import Engine.Events.Sink qualified as Sink +import Engine.Types (StageRIO) + +spawn + :: (event -> StageRIO st ()) + -> [Sink event st -> StageRIO st ReleaseKey] + -> StageRIO st (ReleaseKey, Sink event st) +spawn handleEvent sources = do + (sinkKey, sink) <- Sink.spawn handleEvent + + key <- registerMany $ + pure sinkKey : + map ($ sink) sources + + pure (key, sink) + +registerMany :: [StageRIO st ReleaseKey] -> StageRIO st ReleaseKey +registerMany actions = + sequenceA actions >>= + Resource.register . traverse_ Resource.release diff --git a/src/Engine/Events/CursorPos.hs b/src/Engine/Events/CursorPos.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Events/CursorPos.hs @@ -0,0 +1,35 @@ +module Engine.Events.CursorPos where + +import RIO + +import Geomancy (Vec2, vec2) +import GHC.Float (double2Float) +import UnliftIO.Resource (ReleaseKey) + +import Engine.Types (StageRIO) +import Engine.Window.CursorPos qualified as CursorPos +import Engine.Worker qualified as Worker + +import Engine.Events (Sink) + +callback + :: ( Worker.HasInput cursor + , Worker.GetInput cursor ~ Vec2 + ) + => cursor + ------------------------- + -> Sink e rs + -> StageRIO rs ReleaseKey +callback cursorVar = CursorPos.callback . handler cursorVar + +handler + :: ( Worker.HasInput cursor + , Worker.GetInput cursor ~ Vec2 + ) + => cursor + -> Sink e rs + -> CursorPos.Callback rs +handler cursorVar _sink windowX windowY = do + -- logDebug $ "CursorPos event: " <> displayShow (windowX, windowY) + Worker.pushInput cursorVar \_old -> + vec2 (double2Float windowX) (double2Float windowY) diff --git a/src/Engine/Events/MouseButton.hs b/src/Engine/Events/MouseButton.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Events/MouseButton.hs @@ -0,0 +1,47 @@ +module Engine.Events.MouseButton + ( ClickHandler + , callback + , handler + ) where + +import RIO + +import Geomancy (Vec2) +import UnliftIO.Resource (ReleaseKey) + +import Engine.Events.Sink (Sink) +import Engine.Types (StageRIO) +import Engine.Window.MouseButton (ModifierKeys, MouseButton, MouseButtonState) +import Engine.Window.MouseButton qualified as MouseButton +import Engine.Worker qualified as Worker + +type ClickHandler e st = + Sink e st -> + Vec2 -> + (ModifierKeys, MouseButtonState, MouseButton) -> + StageRIO st () + +callback + :: ( Worker.HasOutput cursor + , Worker.GetOutput cursor ~ Vec2 + ) + => cursor + -> ClickHandler e st + ------------------------- + -> Sink e st + -> StageRIO st ReleaseKey +callback cursorP eventHandler = MouseButton.callback . handler cursorP eventHandler + +handler + :: ( Worker.HasOutput cursor + , Worker.GetOutput cursor ~ Vec2 + ) + => cursor + -> ClickHandler e st + -> Sink e st + -> (ModifierKeys, MouseButtonState, MouseButton) + -> StageRIO st () +handler cursorP eventHandler sink buttonEvent = do + cursorPos <- Worker.getOutputData cursorP + logDebug $ "MouseButton event: " <> displayShow (cursorPos, buttonEvent) + eventHandler sink cursorPos buttonEvent diff --git a/src/Engine/Events/Sink.hs b/src/Engine/Events/Sink.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Events/Sink.hs @@ -0,0 +1,42 @@ +module Engine.Events.Sink + ( Sink(..) + , spawn + ) where + +import RIO + +import Control.Concurrent.Chan.Unagi qualified as Unagi +import Control.Exception (AsyncException(ThreadKilled)) +import UnliftIO.Concurrent (forkFinally, killThread) +import UnliftIO.Resource (ReleaseKey) +import UnliftIO.Resource qualified as Resource + +import Engine.Types (StageRIO) + +newtype Sink event st = Sink + { signal :: event -> StageRIO st () + } + +spawn + :: (event -> StageRIO rs ()) + -> StageRIO rs (ReleaseKey, Sink event rs) +spawn handleEvent = do + (eventsIn, eventsOut) <- liftIO Unagi.newChan + let sink = Sink \event -> liftIO (Unagi.writeChan eventsIn event) + + let + handler = forever $ + liftIO (Unagi.readChan eventsOut) >>= handleEvent + + tid <- forkFinally handler + \case + Left exc -> + case fromException exc of + Just ThreadKilled -> + logDebug "Event thread killed" + _others -> + logError $ "Event thread crashed: " <> displayShow exc + Right () -> + logWarn "Event thread exited prematurely" + key <- Resource.register $ killThread tid + pure (key, sink) diff --git a/src/Engine/Frame.hs b/src/Engine/Frame.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Frame.hs @@ -0,0 +1,352 @@ +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.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.RefCounted (newRefCounted) +import Engine.Vulkan.Swapchain (SwapchainResources(..), SwapchainInfo(..), allocSwapchainResources, recreateSwapchainResources) +import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, RenderPass(..), Queues) + +initial + :: (RenderPass rp) + => Maybe SwapchainResources + -> DumpResource (RecycledResources rr) + -> Stage rp p rr st + -> StageRIO st (Frame rp p rr) +initial oldSR dumpResource Stage{..} = do + logDebug "Making initial frame" + + GlobalHandles{..} <- asks appEnv + let device = ghDevice + + sfSwapchainResources <- case oldSR of + Nothing -> do + windowSize <- liftIO $ Window.getExtent2D ghWindow + let oldSwapchain = Vk.NULL_HANDLE + allocSwapchainResources + oldSwapchain + windowSize + ghSurface + ghScreenP + Just old -> + pure old + + {- XXX: + Create this resource object at the global level so it's closed correctly on exception. + -} + (stageKey, stageResources) <- allocate ResourceT.createInternalState ResourceT.closeInternalState + stageRefCounted <- newRefCounted $ release stageKey + semiFrame <- flip ResourceT.runInternalState stageResources do + {- XXX: + Stages appearing on the top of the stage stack are to create their swapchain-derived resources. + Don't keep the release keys, all resources here are refcounted and live for the lifetime of the stage. + Resources will be released when the stage is finished or suspended and all the frames are done. + -} + + debugAlloc <- toIO . logDebug $ "Allocating inside stage " <> display sTitle + debugRelease <- toIO . logDebug $ "Releasing inside stage " <> display sTitle + void $! ResourceT.allocate_ debugAlloc debugRelease + + -- For each render pass: + sfRenderpass <- allocateRenderpass_ sfSwapchainResources + + -- TODO: Recreate this if the swapchain format changes + sfPipelines <- sAllocateP sfSwapchainResources sfRenderpass + + (_, sfRenderFinishedHostSemaphore) <- Vk.withSemaphore + device + (zero ::& Vk12.SemaphoreTypeCreateInfo Vk12.SEMAPHORE_TYPE_TIMELINE 0 :& ()) + Nothing + allocate + + logDebug $ "Creating initial recycled resources for stage " <> display sTitle + sfRecycledResources <- initialRecycledResources sInitialRR sfRenderpass sfPipelines + replicateM_ (INFLIGHT_FRAMES - 1) do + resources <- initialRecycledResources sInitialRR sfRenderpass sfPipelines + liftIO $ dumpResource resources + + releaseDataDebug <- toIO . logDebug $ "Releasing recycled resources for stage " <> display sTitle + void $! Resource.register releaseDataDebug + + pure + ( sfSwapchainResources + , sfRenderpass + , sfPipelines + , sfRenderFinishedHostSemaphore + , sfRecycledResources + ) + + let + (fSwapchainResources, fRenderpass, fPipelines, fRenderFinishedHostSemaphore, fRecycledResources) = semiFrame + + {- XXX: + Create this resource object at the global level so it's closed correctly on exception. + Recycled frame resources can linger for a bit longer after its stage is gone, thus 'RefCounted'. + -} + fResources <- allocate ResourceT.createInternalState ResourceT.closeInternalState + + fGPUWork <- liftIO $ newIORef mempty + + pure Frame + { fIndex = 1 + , fWindow = ghWindow + , fSurface = ghSurface + , fStageResources = (stageRefCounted, stageResources) + , .. + } + +pattern INFLIGHT_FRAMES :: (Eq a, Num a) => a +pattern INFLIGHT_FRAMES = 2 -- XXX: up to two frames submitted for rendering + +-- | Derive next frame +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 waitDumped f needsNewSwapchain = do + -- Wait for a prior frame to finish, then we can steal it's resources! + + -- Handle mvar indefinite timeout exception here: + -- https://github.com/expipiplus1/vulkan/issues/236 + fRecycledResources <- liftIO $ + waitDumped >>= \case + Left block -> + block + Right rs -> + pure rs + + (fSwapchainResources, fRenderpass) <- getNext f + + -- The per-frame resource helpers need to be created fresh + fGPUWork <- liftIO $ newIORef mempty + fResources <- allocate ResourceT.createInternalState ResourceT.closeInternalState + + pure Frame + { fIndex = fIndex f + 1 + , fWindow = fWindow f + , fSurface = fSurface f + , fPipelines = fPipelines f + , fRenderFinishedHostSemaphore = fRenderFinishedHostSemaphore f + , fStageResources = fStageResources f + , fSwapchainResources + , fRenderpass + , fGPUWork + , fResources + , fRecycledResources + } + where + getNext Frame{..} = do + if needsNewSwapchain then do + windowSize <- liftIO $ Window.getExtent2D fWindow + newResources <- recreateSwapchainResources windowSize fSwapchainResources + + let + formatMatch = + siSurfaceFormat (srInfo newResources) == + siSurfaceFormat (srInfo fSwapchainResources) + unless formatMatch do + logWarn "Swapchain changed format" + throwString "TODO: Handle swapchain changing formats" + + newRenderpass <- updateRenderpass newResources fRenderpass + + pure + ( newResources + , newRenderpass + ) + else + pure + ( fSwapchainResources + , fRenderpass + ) + +run + :: ( HasLogFunc env + , HasVulkan env + , MonadResource (RIO env) + ) + => (RecycledResources rr -> IO ()) + -> RIO (env, Frame rp p rr) a + -> Frame rp p rr + -> RIO env a +run recycle render frame@Frame{..} = do + env <- ask + runRIO (env, frame) render `finally` void (spawn flush) + where + flush = do + device <- asks getDevice + waits <- readIORef fGPUWork + let oneSecondKhr = 1e9 + -- logDebug $ "Waiting Frame " <> displayShow fIndex + + unless (null waits) do + let + waitInfo = zero + { Vk12.semaphores = Vector.fromList (map fst waits) + , Vk12.values = Vector.fromList (map snd waits) + } + waitTwice waitInfo oneSecondKhr >>= \case + Vk.TIMEOUT -> do + logError "Time out (1s) waiting for frame to finish on Device" + timeoutError "Time out (1s) waiting for frame to finish on Device" + {- + XXX: recycler thread will crash now, never recycling its resources, + resulting in an indefinite MVar block. + -} + Vk.SUCCESS -> + pure () + huh -> + logWarn $ "waitTwice returned " <> displayShow huh + + -- logDebug $ "Flushing Frame " <> displayShow fIndex + + -- Free resources wanted elsewhere now, all those in RecycledResources + for_ (rrQueues fRecycledResources) \commandPool -> + Vk.resetCommandPool device commandPool Vk.COMMAND_POOL_RESET_RELEASE_RESOURCES_BIT + + -- Signal we're done by making the recycled resources available + liftIO $ recycle fRecycledResources + + -- Destroy frame-specific resources at our leisure + release (fst fResources) + +-- | 'queueSubmit' and add wait for the timeline 'Semaphore' before retiring the frame. +queueSubmit + :: MonadVulkan env m + => Vk.Queue + -> Vector (SomeStruct Vk.SubmitInfo) + -> IORef [GPUWork] + -> Vk.Semaphore + -> Word64 + -> m () +queueSubmit q submits gpuWork hostSemaphore frameIndex = do + {- + Make sure we don't get interrupted between submitting the work and + recording the wait. + -} + mask \_ -> do + Vk.queueSubmit q submits Vk.NULL_HANDLE + atomicModifyIORef' gpuWork \waits -> + ( (hostSemaphore, frameIndex) : 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 initialRecycledData rps pipes = do + device <- asks getDevice + + (_iaKey, rrImageAvailableSemaphore) <- Vk.withSemaphore + device + (zero ::& Vk12.SemaphoreTypeCreateInfo Vk12.SEMAPHORE_TYPE_BINARY 0 :& ()) + Nothing + allocate + + (_rfKey, rrRenderFinishedSemaphore) <- Vk.withSemaphore + device + (zero ::& Vk12.SemaphoreTypeCreateInfo Vk12.SEMAPHORE_TYPE_BINARY 0 :& ()) + Nothing + allocate + + queues <- asks getQueues + rrQueues <- for queues \(QueueFamilyIndex ix, _queue) -> do + let + commandPoolCI = Vk.CommandPoolCreateInfo + { flags = zero + , queueFamilyIndex = ix + } + cpDebug <- toIO . logDebug $ "Release time for command pool for queue " <> display ix + void $! ResourceT.register cpDebug + fmap snd $! Vk.withCommandPool device commandPoolCI Nothing ResourceT.allocate + + rrData <- initialRecycledData rrQueues rps pipes + + pure RecycledResources{..} + +{- | + Wait for some semaphores, if the wait times out give the frame one last + chance to complete with a zero timeout. + + It could be that the program was suspended during the preceding + wait causing it to timeout, this will check if it actually + finished. +-} +waitTwice + :: (MonadVulkan env m, HasLogFunc env) + => Vk12.SemaphoreWaitInfo + -> "timeout" ::: Word64 + -> m Vk.Result +waitTwice waitInfo t = do + device <- asks getDevice + Vk12.waitSemaphoresSafe device waitInfo t >>= \case + Vk.TIMEOUT -> do + r <- Vk12.waitSemaphores device waitInfo 0 + logWarn $ mconcat + [ "waiting a second time on " <> displayShow waitInfo + , " got " <> displayShow r + ] + pure r + r -> + pure r + +timeoutError :: MonadThrow m => String -> m a +timeoutError message = + throwM $ IOError Nothing TimeExpired "" message Nothing Nothing + +spawn :: (MonadUnliftIO m, MonadResource m) => m a -> m (Async a) +spawn action = do + actionIO <- toIO action + {- + If we don't remove the release key when the thread is done it'll leak, + remove it at the end of the async action when the thread is going to + die anyway. + + Mask this so there's no chance we're inturrupted before writing the mvar. + -} + kv <- newEmptyMVar + mask $ \_ -> do + (k, r) <- allocate + (asyncWithUnmask \unmask -> + unmask $ actionIO <* (Resource.unprotect =<< liftIO (readMVar kv)) + ) + uninterruptibleCancel + putMVar kv k + pure r diff --git a/src/Engine/Render.hs b/src/Engine/Render.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Render.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedLists #-} + +module Engine.Render where + +import RIO +import Vulkan.Exception (VulkanException(..)) + +import Control.Monad.Trans.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.Extensions.VK_KHR_swapchain qualified as Khr +import Vulkan.NamedType ((:::)) +import Vulkan.Zero (zero) + +import Engine.Frame qualified as Frame +import Engine.Types (Frame(..), RecycledResources(..), StageFrameRIO) +import Engine.Types.RefCounted (resourceTRefCount) +import Engine.Vulkan.Swapchain (SwapchainInfo(..), SwapchainResources(..)) +import Engine.Vulkan.Types (HasVulkan(..), RenderPass(..), Queues(..)) + +renderFrame + :: RenderPass rp + => (rr -> StageFrameRIO rp p rr st ()) + -> (Vk.CommandBuffer -> rr -> "image index" ::: Word32 -> StageFrameRIO rp p rr st ()) + -> StageFrameRIO rp p rr st () +renderFrame updateBuffers recordCommandBuffer = do + Frame{..} <- asks snd + let stageRecycled = rrData fRecycledResources + device <- asks getDevice + + let oneSecondKhr = 1e9 + let + RecycledResources{..} = fRecycledResources + SwapchainResources{..} = fSwapchainResources + SwapchainInfo{..} = srInfo + + resourceTRefCount srRelease + resourceTRefCount (fst fStageResources) + refcountRenderpass fRenderpass + + updateBuffers stageRecycled + + (res, imageIndex) <- Khr.acquireNextImageKHRSafe + device + siSwapchain + oneSecondKhr + rrImageAvailableSemaphore + Vk.NULL_HANDLE + + let + proceed = do + -- Allocate a command buffer and populate it + let + commandBufferAI = zero + { Vk.commandPool = qGraphics rrQueues + , Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY + , Vk.commandBufferCount = 1 + } + commandBuffer <- Vk.withCommandBuffers device commandBufferAI Resource.allocate >>= \case + (_key, [one]) -> + pure one + _ -> + throwString "assert: 1 buffer allocated as requested" + + let + commandBufferBI = zero + { Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT + } :: Vk.CommandBufferBeginInfo '[] + Vk.useCommandBuffer commandBuffer commandBufferBI $ + recordCommandBuffer commandBuffer stageRecycled imageIndex + + let + submitInfo = + zero + { Vk.waitSemaphores = + [ rrImageAvailableSemaphore + ] + , Vk.waitDstStageMask = + [ Vk.PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT + ] + , Vk.commandBuffers = + [ Vk.commandBufferHandle commandBuffer + ] + , Vk.signalSemaphores = + [ rrRenderFinishedSemaphore + , fRenderFinishedHostSemaphore + ] + } + ::& zero + { Vk12.waitSemaphoreValues = [1] + , Vk12.signalSemaphoreValues = [1, fIndex] + } + :& () + + -- traceM $ "Submitting frame " <> textDisplay fIndex <> " to image " <> textDisplay imageIndex + Queues{qGraphics=(_family, graphicsPresentQueue)} <- asks getQueues + Frame.queueSubmit + graphicsPresentQueue + [SomeStruct submitInfo] + fGPUWork + fRenderFinishedHostSemaphore + fIndex + + -- traceM $ "Presenting image " <> textDisplay imageIndex <> " from frame " <> textDisplay fIndex + presentRes <- Khr.queuePresentKHR graphicsPresentQueue zero + { Khr.waitSemaphores = [rrRenderFinishedSemaphore] + , Khr.swapchains = [siSwapchain] + , Khr.imageIndices = [imageIndex] + } + case presentRes of + Vk.SUCCESS -> + pure () + Vk.SUBOPTIMAL_KHR -> do + logWarn "[present] Swapchain is suboptimal, forcing update." + throwM $ VulkanException Vk.ERROR_OUT_OF_DATE_KHR + _ -> + -- TODO: check for SUBOPTIMAL_KHR + logWarn $ "Presenting wasn't quite successful: " <> displayShow presentRes + + case res of + Vk.SUCCESS -> + -- logDebug $ "Acquired next image ID: " <> displayShow imageIndex + proceed + + Vk.TIMEOUT -> + logDebug "Timed out (1s) trying to acquire next image" + + Vk.ERROR_OUT_OF_DATE_KHR -> do + {- XXX: + Throwing an exception for 'Engine.Vulkan.Swapchain.threwSwapchainError' to catch. + See also: 'Engine.Run.step'. + -} + logWarn "Swapchain out of date" + throwM $ VulkanException res + + Vk.SUBOPTIMAL_KHR -> do + {- XXX: + Converting 'Vk.SUBOPTIMAL_KHR' error to OOD to trigger swapchain update. + -} + logWarn "[acquire] Swapchain is suboptimal, forcing update." + throwM $ VulkanException Vk.ERROR_OUT_OF_DATE_KHR + + _ -> do + logError $ + "Unexpected Result from acquireNextImageKHR: " <> + fromString (show res) + throwM $ VulkanException res diff --git a/src/Engine/Run.hs b/src/Engine/Run.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Run.hs @@ -0,0 +1,178 @@ +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.RefCounted (releaseRefCounted) +import Engine.Vulkan.Swapchain (SwapchainResources(srRelease), threwSwapchainError) +import Engine.Vulkan.Types (RenderPass, getDevice) + +runStack :: StageStack -> StageRIO (Maybe SwapchainResources) () +runStack = \case + [] -> do + logInfo "Stage stack finished" + get >>= \case + Nothing -> + pure () + Just oldSR -> + releaseRefCounted (srRelease oldSR) + asks getDevice >>= Vk.deviceWaitIdle + threadDelay 0.5e6 -- XXX: this is arbitrary and may not always satisfy the validator + + StackStage stage : rest -> do + logInfo $ "Setting up stage " <> display (sTitle stage) + (stageRelease, runner) <- prepareStage (sInitialRS stage) + oldSR <- get + runner (run oldSR stageRelease stage) >>= proceed stageRelease rest + + StackStageContinue stKey state stage : rest -> do + logInfo $ "Resuming stage " <> display (sTitle stage) + (stageRelease, runner) <- prepareStage (pure (stKey, state)) + oldSR <- get + runner (run oldSR stageRelease stage) >>= proceed stageRelease rest + +type StageResult = (SwapchainResources, StageAction) + +proceed :: ReleaseKey -> StageStack -> StageResult -> StageRIO (Maybe SwapchainResources) () +proceed stageRelease rest (oldSR, stageAction) = do + put (Just oldSR) + case stageAction of + StageDone -> do + logInfo "Stage done" + release stageRelease + runStack rest + StageReplace nextStage -> do + logInfo "Stage replaced" + release stageRelease + runStack (nextStage : rest) + StagePush frozenStage nextStage -> do + case frozenStage of + StackStage{} -> + logInfo "Restarting stage pushed" + StackStageContinue{} -> + logInfo "Frozen stage pushed" + runStack (nextStage : frozenStage : rest) + +prepareStage + :: StageRIO env (ReleaseKey, st) + -> StageRIO env (ReleaseKey, StageRIO st a -> StageRIO env a) +prepareStage initialRS = do + (key, rs) <- initialRS + freshStateVar <- newSomeRef rs + App{..} <- ask + let + stageApp = App + { appState = freshStateVar + , .. + } + pure (key, runRIO stageApp) + +run + :: RenderPass rp + => Maybe SwapchainResources + -> ReleaseKey + -> Stage rp p rr st + -> StageRIO st StageResult +run oldSR stKey stage@Stage{..} = do + logInfo $ "Starting stage: " <> display sTitle + + recycler <- DataRecycler.new + + startFrame <- Frame.initial oldSR (drDump recycler) stage + + logInfo $ "Entering stage loop: " <> display sTitle + startTime <- getMonotonicTime + (finalFrame, stageAction) <- bracket sBeforeLoop sAfterLoop \_stagePrivates -> + stageLoop (step stKey stage recycler) startFrame + endTime <- getMonotonicTime + let + frames = Frame.fIndex finalFrame + seconds = endTime - startTime + + logInfo $ "Stage finished: " <> display sTitle + logInfo $ "Running time: " <> display seconds + logInfo $ "Average FPS: " <> display (fromIntegral frames / seconds) + releaseRefCounted $ fst (Frame.fStageResources finalFrame) + pure + ( Frame.fSwapchainResources finalFrame + , 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 stKey stage@Stage{..} DataRecycler{..} frame = do + liftIO GLFW.pollEvents + + -- XXX: hard unwind all the stages, rendering nothing + quit <- liftIO $ GLFW.windowShouldClose (Frame.fWindow frame) + + if quit then + pure LoopQuit + else + getNextStage >>= \case + Nothing -> do + needsNewSwapchain <- threwSwapchainError do + rs <- get + Frame.run drDump (renderFrame (sUpdateBuffers rs) sRecordCommands) frame + nextFrame <- Frame.advance drWait frame needsNewSwapchain + + pure $ LoopNextFrame nextFrame + Just Finish -> + -- XXX: finish the stage and proceed with the remaining stack + pure LoopQuit + Just (Replace nextStage) -> + pure $ LoopReplaceStage frame nextStage + Just (PushRestart nextStage) -> + pure $ LoopPushStage frame (StackStage stage) nextStage + Just (PushFreeze nextStage) -> do + frozen <- freeze stKey stage + pure $ LoopPushStage frame frozen nextStage + +freeze :: RenderPass rp => ReleaseKey -> Stage rp p rr st -> StageRIO st StackStage +freeze stKey stage = do + st <- get + pure $ StackStageContinue stKey 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 action current = + action current >>= \case + LoopNextFrame nextFrame -> + stageLoop action nextFrame + LoopQuit -> + pure (current, StageDone) + LoopReplaceStage lastFrame nextStage -> + pure (lastFrame, StageReplace nextStage) + LoopPushStage lastFrame frozenStage nextStage -> + pure (lastFrame, StagePush frozenStage nextStage) diff --git a/src/Engine/Setup.hs b/src/Engine/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Setup.hs @@ -0,0 +1,95 @@ +module Engine.Setup where + +import RIO + +import UnliftIO.Resource (MonadResource) +import UnliftIO.Resource qualified as Resource +import Vulkan.Core10 qualified as Vk +import Vulkan.Extensions.VK_EXT_debug_utils qualified as Ext +import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 qualified as Khr +import Vulkan.Requirement (InstanceRequirement(..)) +import Vulkan.Utils.Initialization (createInstanceFromRequirements) +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..)) +import Vulkan.Zero (zero) +import VulkanMemoryAllocator qualified as VMA + +import Engine.Camera qualified as Camera +import Engine.Setup.Device (allocatePhysical, allocateLogical) +import Engine.Setup.Window qualified as Window +import Engine.Types (GlobalHandles(..)) +import Engine.Types.Options (Options, optionsFullscreen) +import Engine.Vulkan.Swapchain (SwapchainResources) +import Engine.Vulkan.Types (PhysicalDeviceInfo(..)) +import Engine.Worker qualified as Worker +import Engine.StageSwitch (newStageSwitchVar) + +setup + :: ( HasLogFunc env + , MonadResource (RIO env) + ) + => Options -> RIO env (GlobalHandles, Maybe SwapchainResources) +setup opts = do + logDebug $ displayShow opts + + (windowReqs, ghWindow) <- Window.allocate + (optionsFullscreen opts) + Window.pickLargest + "Keid Engine" + + logDebug "Creating instance" + ghInstance <- createInstanceFromRequirements + (deviceProps : debugUtils : windowReqs) + mempty + zero + + logDebug "Creating surface" + (_surfaceKey, ghSurface) <- Window.allocateSurface ghWindow ghInstance + + logDebug "Creating physical device" + (ghPhysicalDeviceInfo, ghPhysicalDevice) <- allocatePhysical + ghInstance + ghSurface + pdiTotalMemory + + logDebug "Creating logical device" + ghDevice <- allocateLogical ghPhysicalDeviceInfo ghPhysicalDevice + + logDebug "Creating VMA" + let + allocatorCI :: VMA.AllocatorCreateInfo + allocatorCI = zero + { VMA.physicalDevice = Vk.physicalDeviceHandle ghPhysicalDevice + , VMA.device = Vk.deviceHandle ghDevice + , VMA.instance' = Vk.instanceHandle ghInstance + } + (_vmaKey, ghAllocator) <- VMA.withAllocator allocatorCI Resource.allocate + toIO (logDebug "Releasing VMA") >>= Resource.register + + ghQueues <- liftIO $ pdiGetQueues ghPhysicalDeviceInfo ghDevice + logDebug $ "Got command queues: " <> displayShow (fmap (unQueueFamilyIndex . fst) ghQueues) + + screen <- liftIO $ Window.getExtent2D ghWindow + (_screenKey, ghScreenP) <- Worker.registered $ + Worker.spawnCell Camera.mkProjection Camera.ProjectionInput + { projectionFovRads = τ / 4 + , projectionScreen = screen + } + + ghStageSwitch <- newStageSwitchVar + + pure (GlobalHandles{..}, Nothing) + +deviceProps :: InstanceRequirement +deviceProps = RequireInstanceExtension + Nothing + Khr.KHR_GET_PHYSICAL_DEVICE_PROPERTIES_2_EXTENSION_NAME + minBound + +debugUtils :: InstanceRequirement +debugUtils = RequireInstanceExtension + Nothing + Ext.EXT_DEBUG_UTILS_EXTENSION_NAME + minBound + +τ :: Float +τ = 2 * pi diff --git a/src/Engine/Setup/Device.hs b/src/Engine/Setup/Device.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Setup/Device.hs @@ -0,0 +1,202 @@ +-- | Physical device tools + +module Engine.Setup.Device where + +import RIO + +import Control.Monad.Trans.Maybe (MaybeT(..)) +import GHC.IO.Exception (IOException(..), IOErrorType(NoSuchThing)) +import RIO.Vector qualified as V +import UnliftIO.Resource (MonadResource) +import UnliftIO.Resource qualified as Resource +import Vulkan.Core10 qualified as Vk +import Vulkan.Core11.Promoted_From_VK_KHR_multiview (PhysicalDeviceMultiviewFeatures(..)) +import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing (PhysicalDeviceDescriptorIndexingFeatures(..)) +import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore (PhysicalDeviceTimelineSemaphoreFeatures(..)) +import Vulkan.CStruct.Extends ( SomeStruct(SomeStruct), pattern (:&), pattern (::&)) +import Vulkan.Extensions.VK_KHR_get_physical_device_properties2 (getPhysicalDeviceFeatures2KHR) +import Vulkan.Extensions.VK_KHR_surface qualified as Khr +import Vulkan.Extensions.VK_KHR_swapchain (pattern KHR_SWAPCHAIN_EXTENSION_NAME) +import Vulkan.Extensions.VK_KHR_timeline_semaphore (pattern KHR_TIMELINE_SEMAPHORE_EXTENSION_NAME) +import Vulkan.Utils.Initialization (createDeviceFromRequirements, physicalDeviceName, pickPhysicalDevice) +import Vulkan.Utils.QueueAssignment (QueueSpec(..)) +import Vulkan.Utils.QueueAssignment qualified as Utils +import Vulkan.Utils.Requirements.TH qualified as Utils +import Vulkan.Core10 (PhysicalDeviceFeatures(..)) +import Vulkan.Zero (zero) + +import Engine.Vulkan.Types (PhysicalDeviceInfo(..), Queues(..)) + +allocatePhysical + :: ( MonadUnliftIO m, MonadThrow m + , MonadReader env m + , HasLogFunc env + , MonadResource m + ) + => Vk.Instance + -> Khr.SurfaceKHR + -> (PhysicalDeviceInfo -> Word64) + -> m (PhysicalDeviceInfo, Vk.PhysicalDevice) +allocatePhysical vkInstance surface score = do + UnliftIO unliftIO <- askUnliftIO + + let + create = unliftIO do + logDebug "Picking physical device..." + pickPhysicalDevice vkInstance (physicalDeviceInfo surface) score >>= \case + Nothing -> + noSuchThing "Unable to find appropriate PhysicalDevice" + Just res@(pdi, _dev) -> do + logInfo $ mconcat + [ "Using physical device: " + , displayShow (pdiName pdi) + ] + pure res + + destroy _res = unliftIO $ + logDebug "Destroying physical device" + + fmap snd $ Resource.allocate create destroy + +physicalDeviceInfo + :: ( MonadIO m + , MonadReader env m + , HasLogFunc env + ) + => Khr.SurfaceKHR -> Vk.PhysicalDevice -> m (Maybe PhysicalDeviceInfo) +physicalDeviceInfo surf phys = runMaybeT do + pdiName <- physicalDeviceName phys + logDebug $ "Considering " <> displayShow pdiName + + hasTimelineSemaphores <- deviceHasTimelineSemaphores phys + unless hasTimelineSemaphores do + logWarn $ mconcat + [ "Not using physical device " + , displayShow pdiName + , " because it doesn't support timeline semaphores" + ] + + hasSwapchainSupport <- deviceHasSwapchain phys + unless hasSwapchainSupport do + logWarn $ mconcat + [ "Not using physical device " + , displayShow pdiName + , " because it doesn't support swapchains" + ] + + (pdiQueueCreateInfos, pdiGetQueues) <- MaybeT $ + Utils.assignQueues phys (queueRequirements phys surf) + + pdiTotalMemory <- do + props <- Vk.getPhysicalDeviceMemoryProperties phys + pure . sum $ + fmap + (Vk.size :: Vk.MemoryHeap -> Vk.DeviceSize) + (Vk.memoryHeaps props) + + pdiProperties <- Vk.getPhysicalDeviceProperties phys + + pure PhysicalDeviceInfo{..} + +{- | + Requirements for a 'Queue' which has graphics support and can present to + the specified surface. + + Priorities are ranged 0.0 to 1.0 with higher number means higher priority. + https://www.khronos.org/registry/vulkan/specs/1.2-extensions/html/vkspec.html#devsandqueues-priority +-} +queueRequirements + :: MonadIO m + => Vk.PhysicalDevice -> Khr.SurfaceKHR -> Queues (QueueSpec m) +queueRequirements phys surf = Queues + { qGraphics = QueueSpec 1.0 isGraphicsPresentQueue + , qCompute = QueueSpec 0.5 isComputeQueue + , qTransfer = QueueSpec 0.0 isTransferQueue + } + where + isGraphicsPresentQueue queueFamilyIndex queueFamilyProperties = do + pq <- Utils.isPresentQueueFamily phys surf queueFamilyIndex + let gq = Utils.isGraphicsQueueFamily queueFamilyProperties + pure $ pq && gq + + isTransferQueue _queueFamilyIndex queueFamilyProperties = + pure $ Utils.isTransferQueueFamily queueFamilyProperties + + isComputeQueue _queueFamilyIndex queueFamilyProperties = + pure $ Utils.isComputeQueueFamily queueFamilyProperties + +deviceHasSwapchain :: MonadIO m => Vk.PhysicalDevice -> m Bool +deviceHasSwapchain dev = do + (_, extensions) <- Vk.enumerateDeviceExtensionProperties dev Nothing + pure $ V.any + ((KHR_SWAPCHAIN_EXTENSION_NAME ==) . Vk.extensionName) + extensions + +deviceHasTimelineSemaphores :: MonadIO m => Vk.PhysicalDevice -> m Bool +deviceHasTimelineSemaphores phys = do + (_, extensions) <- Vk.enumerateDeviceExtensionProperties phys Nothing + let + hasExt = V.any + ((KHR_TIMELINE_SEMAPHORE_EXTENSION_NAME ==) . Vk.extensionName) + extensions + + hasFeat <- getPhysicalDeviceFeatures2KHR phys >>= \case + _ ::& (PhysicalDeviceTimelineSemaphoreFeatures hasTimelineSemaphores :& ()) -> + pure hasTimelineSemaphores + _ -> + pure False + + pure $ hasExt && hasFeat + +allocateLogical + :: ( MonadUnliftIO m + , MonadReader env m, HasLogFunc env + , MonadResource m + ) + => PhysicalDeviceInfo -> Vk.PhysicalDevice -> m Vk.Device +allocateLogical pdi pd = do + logDebug "Creating logical device" + + ld <- createDeviceFromRequirements + [Utils.reqs| + 1.2 + + VK_KHR_maintenance3 + VK_KHR_swapchain + + -- PhysicalDeviceFeatures.robustBufferAccess + PhysicalDeviceFeatures.textureCompressionBC + + VK_KHR_multiview + PhysicalDeviceMultiviewFeatures.multiview + + VK_EXT_descriptor_indexing + PhysicalDeviceDescriptorIndexingFeatures.descriptorBindingPartiallyBound + PhysicalDeviceDescriptorIndexingFeatures.descriptorBindingVariableDescriptorCount + PhysicalDeviceDescriptorIndexingFeatures.runtimeDescriptorArray + PhysicalDeviceDescriptorIndexingFeatures.shaderSampledImageArrayNonUniformIndexing + + VK_KHR_timeline_semaphore + PhysicalDeviceTimelineSemaphoreFeatures.timelineSemaphore + |] + [Utils.reqs| + PhysicalDeviceFeatures.samplerAnisotropy + PhysicalDeviceFeatures.sampleRateShading + |] + pd + deviceCI + + toIO (logDebug "Destroying logical device") >>= + Resource.register + + pure ld + + where + deviceCI = zero + { Vk.queueCreateInfos = fmap SomeStruct (pdiQueueCreateInfos pdi) + } + +noSuchThing :: MonadThrow m => String -> m a +noSuchThing message = + throwM $ + IOError Nothing NoSuchThing "" message Nothing Nothing diff --git a/src/Engine/Setup/Window.hs b/src/Engine/Setup/Window.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Setup/Window.hs @@ -0,0 +1,171 @@ +module Engine.Setup.Window + ( GLFW.Window + , allocate + , createWindow + , destroyWindow + + , SizePicker + , pickLargest + + , Khr.SurfaceKHR + , allocateSurface + , createSurface + + , getExtent2D + + , GLFWError + , GLFW.Error + ) where + +import RIO hiding (some) + +import Data.List.NonEmpty qualified as NonEmpty +import Foreign qualified +import Graphics.UI.GLFW qualified as GLFW +import RIO.ByteString qualified as BS +import RIO.Text qualified as Text +import UnliftIO.Resource (MonadResource) +import UnliftIO.Resource qualified as Resource +import Vulkan.Core10 qualified as Vk +import Vulkan.Extensions.VK_KHR_surface qualified as Khr +import Vulkan.Requirement (InstanceRequirement(..)) + +data GLFWError + = InitError GLFW.Error String + | VulkanError GLFW.Error String + | MonitorError GLFW.Error String + | VideoModeError GLFW.Error String + | WindowError GLFW.Error String + | SurfaceError Vk.Result + deriving (Eq, Ord, Show) + +instance Exception GLFWError + +type SizePicker = NonEmpty (GLFW.Monitor, GLFW.VideoMode) -> (GLFW.Monitor, GLFW.VideoMode) + +allocate + :: ( MonadUnliftIO m + , MonadReader env m, HasLogFunc env + , MonadResource m + ) + => Bool + -> SizePicker + -> Text + -> m ([InstanceRequirement], GLFW.Window) +allocate fullscreen sizePicker title = do + UnliftIO unliftIO <- askUnliftIO + + let + create = unliftIO $ + createWindow fullscreen sizePicker title + + destroy (_exts, window) = unliftIO $ + destroyWindow window + + fmap snd $ Resource.allocate create destroy + +createWindow + :: (MonadIO m, MonadReader env m, HasLogFunc env) + => Bool -> SizePicker -> Text -> m ([InstanceRequirement], GLFW.Window) +createWindow fullScreen sizePicker title = do + runGlfwIO_ InitError GLFW.init + runGlfwIO_ VulkanError GLFW.vulkanSupported + + liftIO . GLFW.windowHint $ GLFW.WindowHint'ClientAPI GLFW.ClientAPI'NoAPI + + sizes <- runGlfwIO MonitorError GLFW.getMonitors >>= \case + [] -> + liftIO . throwIO $ MonitorError GLFW.Error'PlatformError "No monitors returned" + some -> + fmap NonEmpty.fromList $ + for some \monitor -> do + mode <- runGlfwIO VideoModeError $ GLFW.getVideoMode monitor + pure (monitor, mode) + + let + (monitor, mode) = sizePicker sizes + GLFW.VideoMode{videoModeWidth=width, videoModeHeight=height} = mode + fsMonitor = + if fullScreen then + Just monitor + else + Nothing + + logDebug $ "Display mode picked: " <> displayShow mode + + window <- runGlfwIO WindowError $ + GLFW.createWindow width height (Text.unpack title) fsMonitor Nothing + + extNamesC <- liftIO $ GLFW.getRequiredInstanceExtensions + extNames <- liftIO $ traverse BS.packCString extNamesC + + when fullScreen $ + liftIO $ GLFW.setFullscreen window monitor mode + + let + instanceReqs = do + name <- extNames + pure $ RequireInstanceExtension Nothing name minBound + + pure (instanceReqs, window) + +destroyWindow + :: (MonadIO m, MonadReader env m, HasLogFunc env) + => GLFW.Window -> m () +destroyWindow window = do + logDebug "Destroying GLFW window" + liftIO do + GLFW.destroyWindow window + GLFW.terminate + +allocateSurface + :: MonadResource m + => GLFW.Window + -> Vk.Instance + -> m (Resource.ReleaseKey, Khr.SurfaceKHR) +allocateSurface window instance_ = + Resource.allocate + (createSurface window instance_) + (\surf -> Khr.destroySurfaceKHR instance_ surf Nothing) + +createSurface :: MonadIO m => GLFW.Window -> Vk.Instance -> m Khr.SurfaceKHR +createSurface window instance_ = + liftIO $ Foreign.alloca \dst -> do + vkResult <- GLFW.createWindowSurface @Foreign.Int32 inst window Foreign.nullPtr dst + if vkResult == 0 then + fmap Khr.SurfaceKHR $ Foreign.peek dst + else + throwIO . SurfaceError $ Vk.Result vkResult + where + inst = Foreign.castPtr $ Vk.instanceHandle instance_ + +runGlfwIO_ :: MonadIO io => (GLFW.Error -> String -> GLFWError) -> IO Bool -> io () +runGlfwIO_ cons action = + runGlfwIO cons $ action >>= \case + True -> + pure $ Just () + False -> + pure Nothing + +runGlfwIO :: MonadIO io => (GLFW.Error -> String -> GLFWError) -> IO (Maybe a) -> io a +runGlfwIO cons action = + liftIO $ action >>= \case + Just res -> + pure res + Nothing -> + GLFW.getError >>= \case + Just (err, msg) -> + throwIO $ cons err msg + Nothing -> + throwIO $ cons GLFW.Error'PlatformError "Unknown error" + +pickLargest :: SizePicker +pickLargest monitors = NonEmpty.head $ NonEmpty.sortBy (flip compare `on` getArea) monitors + where + getArea (_mon, GLFW.VideoMode{videoModeWidth=w, videoModeHeight=h}) = + w * h + +getExtent2D :: GLFW.Window -> IO Vk.Extent2D +getExtent2D window = do + (width, height) <- GLFW.getFramebufferSize window + pure $ Vk.Extent2D (fromIntegral width) (fromIntegral height) diff --git a/src/Engine/Stage/Bootstrap/Setup.hs b/src/Engine/Stage/Bootstrap/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Stage/Bootstrap/Setup.hs @@ -0,0 +1,87 @@ +module Engine.Stage.Bootstrap.Setup + ( stackStage + , bootstrapStage + ) where + +import RIO + +import Control.Monad.Trans.Resource (ResourceT) +import UnliftIO.Resource qualified as Resource +import Vulkan.Core10 qualified as Vk +import Vulkan.NamedType ((:::)) + +import Engine.Types (StackStage(..), StageRIO, StageFrameRIO) +import Engine.Types qualified as Engine +import Engine.Vulkan.Types (Queues) +import Engine.StageSwitch (trySwitchStage) + +import Engine.Stage.Bootstrap.Types (NoRendering(..), NoPipelines(..), NoResources(..), NoState(..)) + +stackStage + :: (a -> StackStage) + -> Engine.StageSetupRIO a + -> StackStage +stackStage handoff action = StackStage $ bootstrapStage handoff action + +bootstrapStage + :: (a -> StackStage) + -> Engine.StageSetupRIO a + -> Engine.Stage NoRendering NoPipelines NoResources NoState +bootstrapStage handoff action = Engine.Stage + { sTitle = "Bootstrap" + + , sAllocateP = noPipelines + , sInitialRS = transitState handoff action + , sInitialRR = noFrameResources + + , sBeforeLoop = pure () + , sUpdateBuffers = noUpdates + , sRecordCommands = noCommands + , sAfterLoop = pure + } + +noPipelines :: swapchain -> NoRendering -> ResourceT (StageRIO st) NoPipelines +noPipelines _swapchain NoRendering = + pure NoPipelines + +noCommands + :: Vk.CommandBuffer + -> rd + -> "image index" ::: Word32 + -> StageFrameRIO rp p rd st () +noCommands _cb _rd _index = + pure () + +noUpdates + :: st + -> rd + -> StageFrameRIO rp p rd st () +noUpdates _st _rd = + pure () + +transitState + :: (a -> StackStage) + -> Engine.StageSetupRIO a + -> Engine.StageSetupRIO (Resource.ReleaseKey, NoState) +transitState handoff action = do + res <- action + + switched <- trySwitchStage . Engine.Replace $ + handoff res + + unless switched $ + logError "Bootstrap switch failed" + + key <- Resource.register $ pure () + pure (key, NoState) + +noFrameResources + :: Queues Vk.CommandPool + -> renderPasses + -> pipelines + -> ResourceT (StageRIO rs) NoResources +noFrameResources _queues _rp _p = + fmap snd $! + Resource.allocate + (pure NoResources) + (\NoResources -> pure ()) diff --git a/src/Engine/Stage/Bootstrap/Types.hs b/src/Engine/Stage/Bootstrap/Types.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Stage/Bootstrap/Types.hs @@ -0,0 +1,28 @@ +module Engine.Stage.Bootstrap.Types + ( Stage + + , NoRendering(..) + , NoPipelines(..) + , NoResources(..) + , NoState(..) + ) where + +import RIO + +import Engine.Vulkan.Types (RenderPass(..)) +import Engine.Types qualified as Engine + +data NoRendering = NoRendering + +instance RenderPass NoRendering where + allocateRenderpass_ _context = pure NoRendering + updateRenderpass _context = pure + refcountRenderpass _rp = pure () + +data NoPipelines = NoPipelines + +type Stage = Engine.Stage NoRendering NoPipelines NoResources NoState + +data NoResources = NoResources + +data NoState = NoState diff --git a/src/Engine/StageSwitch.hs b/src/Engine/StageSwitch.hs new file mode 100644 --- /dev/null +++ b/src/Engine/StageSwitch.hs @@ -0,0 +1,42 @@ +module Engine.StageSwitch + ( StageSwitchVar + , newStageSwitchVar + + , StageSwitch(..) + , trySwitchStage + , trySwitchStageSTM + , getNextStage + ) where + +import RIO + +import RIO.App (appEnv) + +import Engine.Types (NextStage, StageRIO, StageSwitch(..), StageSwitchVar) +import Engine.Types qualified as Engine + +newStageSwitchVar :: MonadIO m => m StageSwitchVar +newStageSwitchVar = newEmptyTMVarIO + +trySwitchStage :: NextStage -> StageRIO rs Bool +trySwitchStage nextStage = do + var <- asks $ Engine.ghStageSwitch . appEnv + atomically $ trySwitchStageSTM var nextStage + +trySwitchStageSTM :: StageSwitchVar -> NextStage -> STM Bool +trySwitchStageSTM switchVar = tryPutTMVar switchVar . StageSwitchPending + +getNextStage :: StageRIO rs (Maybe NextStage) +getNextStage = do + var <- asks $ Engine.ghStageSwitch . appEnv + atomically do + noSwitch <- isEmptyTMVar var + if noSwitch then + pure Nothing + else + takeTMVar var >>= \case + StageSwitchPending nextStage -> do + putTMVar var StageSwitchHandled + pure $ Just nextStage + StageSwitchHandled -> + pure Nothing diff --git a/src/Engine/Types.hs b/src/Engine/Types.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Types.hs @@ -0,0 +1,171 @@ +module Engine.Types where + +import RIO + +import Control.Monad.Trans.Resource (ResourceT) +import Control.Monad.Trans.Resource qualified as ResourceT +import Graphics.UI.GLFW qualified as GLFW +import RIO.App (App, appEnv) +import RIO.Lens (_1) +import UnliftIO.Resource (MonadResource, ReleaseKey) +import Vulkan.Core10 qualified as Vk +import Vulkan.Extensions.VK_KHR_surface qualified as Khr +import Vulkan.NamedType ((:::)) +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..)) +import VulkanMemoryAllocator qualified as VMA + +import Engine.Camera (ProjectionProcess) +import Engine.Setup.Window (Window) +import Engine.Types.RefCounted (RefCounted) +import Engine.Vulkan.Swapchain (SwapchainResources(..)) +import Engine.Vulkan.Types (HasVulkan(..)) +import Engine.Vulkan.Types qualified as Vulkan + +-- * App globals + +-- | A bunch of global, unchanging state we cart around +data GlobalHandles = GlobalHandles + { ghWindow :: GLFW.Window + , ghSurface :: Khr.SurfaceKHR + , ghInstance :: Vk.Instance + , ghPhysicalDevice :: Vk.PhysicalDevice + , ghPhysicalDeviceInfo :: Vulkan.PhysicalDeviceInfo + , ghDevice :: Vk.Device + , ghAllocator :: VMA.Allocator + , ghQueues :: Vulkan.Queues (QueueFamilyIndex, Vk.Queue) + , ghScreenP :: ProjectionProcess + , ghStageSwitch :: StageSwitchVar + } + +getScreenP :: MonadReader (App GlobalHandles s) m => m ProjectionProcess +getScreenP = asks $ ghScreenP . appEnv + +instance HasVulkan GlobalHandles where + getInstance = ghInstance + getQueues = ghQueues + getPhysicalDevice = ghPhysicalDevice + getPhysicalDeviceInfo = ghPhysicalDeviceInfo + getDevice = ghDevice + getAllocator = ghAllocator + +-- * Stage stack + +type StageStack = [StackStage] + +data NextStage + = Finish + | Replace StackStage + | PushRestart StackStage + | PushFreeze StackStage + +data StackStage where + StackStage + :: forall rp p rr st + . Vulkan.RenderPass rp + => Stage rp p rr st + -> StackStage + StackStageContinue + :: forall rp p rr st + . Vulkan.RenderPass rp + => ReleaseKey + -> st + -> Stage rp p rr st + -> StackStage + +type StageSwitchVar = TMVar StageSwitch + +data StageSwitch + = StageSwitchPending NextStage + | StageSwitchHandled + +-- * Stage on a stack + +type StageRIO st = RIO (App GlobalHandles st) + +type StageSetupRIO = RIO (App GlobalHandles (Maybe SwapchainResources)) + +type StageFrameRIO rp p rr st = RIO (App GlobalHandles st, Frame rp p rr) + +data Stage rp p rr st = forall a . Stage + { sTitle :: Text + + , sAllocateP :: SwapchainResources -> rp -> ResourceT (StageRIO st) p + , sInitialRS :: StageRIO (Maybe SwapchainResources) (ReleaseKey, st) + , sInitialRR :: Vulkan.Queues Vk.CommandPool -> rp -> p -> ResourceT (StageRIO st) rr + + , sBeforeLoop :: StageRIO st a + , sUpdateBuffers :: st -> rr -> StageFrameRIO rp p rr st () + , sRecordCommands :: Vk.CommandBuffer -> rr -> "image index" ::: Word32 -> StageFrameRIO rp p rr st () + , sAfterLoop :: a -> StageRIO st () + } + +-- * Frame loop inside a stage + +-- | All the information required to render a single frame +data Frame renderpass pipelines resources = Frame + { fIndex :: Word64 -- ^ Which number frame is this + , fWindow :: Window + , fSurface :: Khr.SurfaceKHR + + , fSwapchainResources :: SwapchainResources + , fRenderpass :: renderpass + , fPipelines :: pipelines + , fRenderFinishedHostSemaphore :: Vk.Semaphore + {- ^ + A timeline semaphore which increments to fIndex when this frame + is done, the host can wait on this semaphore. + -} + + , fStageResources :: (RefCounted, ResourceT.InternalState) + -- ^ Swapchain-derived resources with a life time of this Frame's stage. + + , fGPUWork :: IORef [GPUWork] + {- ^ + Timeline semaphores and corresponding wait values, updates as the + frame progresses. + -} + + , fResources :: (ReleaseKey, ResourceT.InternalState) + {- ^ + The 'InternalState' for tracking frame-local resources along with the + key to release it in the global scope. This will be released when the + frame is done with GPU work. + -} + + , fRecycledResources :: RecycledResources resources + {- ^ + Resources which can be used for this frame and are then passed on to a + later frame. + -} + } + +type GPUWork = + ( "host semaphore" ::: Vk.Semaphore + , "frame index" ::: Word64 + ) + +-- | These are resources which are reused by a later frame when the current +-- frame is retired +data RecycledResources a = RecycledResources + { rrImageAvailableSemaphore :: Vk.Semaphore + -- ^ A binary semaphore passed to 'acquireNextImageKHR' + , rrRenderFinishedSemaphore :: Vk.Semaphore + -- ^ A binary semaphore to synchronize rendering and presenting + + , rrQueues :: Vulkan.Queues Vk.CommandPool + {- ^ + Pool for this frame's commands for each of the queue families. + (might want more than one of these for multithreaded recording) + -} + + , rrData :: a + } + +instance HasLogFunc env => HasLogFunc (env, Frame rp p rr) where + logFuncL = _1 . logFuncL + +instance MonadResource (RIO (env, Frame rp p rr)) where + {-# INLINE liftResourceT #-} + liftResourceT rt = + asks (snd . fResources . snd) >>= + liftIO . ResourceT.runInternalState rt diff --git a/src/Engine/Types/Options.hs b/src/Engine/Types/Options.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Types/Options.hs @@ -0,0 +1,50 @@ +module Engine.Types.Options + ( Options(..) + , getOptions + , optionsP + ) where + +import RIO + +import Options.Applicative.Simple qualified as Opt + +import Paths_keid_core qualified + +-- | Command line arguments +data Options = Options + { optionsVerbose :: Bool + , optionsFullscreen :: Bool + } + deriving (Show) + +getOptions :: IO Options +getOptions = do + (options, ()) <- Opt.simpleOptions + $(Opt.simpleVersion Paths_keid_core.version) + header + description + optionsP + Opt.empty + pure options + where + header = + "Another playground" + + description = + mempty + +optionsP :: Opt.Parser Options +optionsP = do + optionsVerbose <- Opt.switch $ mconcat + [ Opt.long "verbose" + , Opt.short 'v' + , Opt.help "Show more and more detailed messages" + ] + + optionsFullscreen <- Opt.switch $ mconcat + [ Opt.long "fullscreen" + , Opt.short 'f' + , Opt.help "Run in fullscreen mode" + ] + + pure Options{..} diff --git a/src/Engine/Types/RefCounted.hs b/src/Engine/Types/RefCounted.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Types/RefCounted.hs @@ -0,0 +1,50 @@ +module Engine.Types.RefCounted where + +import RIO + +import Control.Monad.Trans.Resource (allocate_) +import GHC.IO.Exception (IOErrorType(UserError), IOException(IOError)) +import UnliftIO.Resource (MonadResource) + +-- | A 'RefCounted' will perform the specified action when the count reaches 0 +data RefCounted = RefCounted + { rcCount :: IORef Int + , rcAction :: IO () + } + +-- | Create a counter with a value of 1 +newRefCounted :: MonadIO m => IO () -> m RefCounted +newRefCounted rcAction = do + rcCount <- liftIO $ newIORef 1 + pure RefCounted{..} + +-- | Decrement the value, the action will be run promptly and in +-- this thread if the counter reached 0. +releaseRefCounted :: MonadIO m => RefCounted -> m () +releaseRefCounted RefCounted{..} = + liftIO $ mask \_ -> + atomicModifyIORef' rcCount (\c -> (c - 1, c - 1)) >>= \case + n | n < 0 -> + throwM $ IOError + Nothing + UserError + "" + "Ref counted value decremented below 0" + Nothing + Nothing + + 0 -> + rcAction + + _stillReferenced -> + pure () + +-- | Increment the counter by 1 +takeRefCounted :: MonadIO m => RefCounted -> m () +takeRefCounted RefCounted{..} = + liftIO $ atomicModifyIORef' rcCount \c -> (c + 1, ()) + +-- | Hold a reference for the duration of the 'MonadResource' action +resourceTRefCount :: MonadResource f => RefCounted -> f () +resourceTRefCount r = + void $ allocate_ (takeRefCounted r) (releaseRefCounted r) diff --git a/src/Engine/UI/Layout.hs b/src/Engine/UI/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Engine/UI/Layout.hs @@ -0,0 +1,364 @@ +module Engine.UI.Layout + ( BoxProcess + , Box(..) + , trackScreen + , padAbs + , hSplitRel + , vSplitRel + + , splitsRelStatic + , sharePadsH + , sharePadsV + + , boxPadAbs + , sharePads + + , fitPlaceAbs + , boxFitPlace + , boxFitScale + + , boxRectAbs + , boxTransformAbs + + , Alignment(..) + , pattern LeftTop + , pattern LeftMiddle + , pattern LeftBottom + , pattern CenterTop + , pattern Center + , pattern CenterBottom + , pattern RightTop + , pattern RightMiddle + , pattern RightBottom + , Origin(..) + + , whenInBoxP + , pointInBox + ) where + +import RIO + +import Data.Traversable (mapAccumL) +import Geomancy (Transform, Vec2, Vec4, vec2, vec4, withVec2, pattern WithVec2, pattern WithVec4) +import Geomancy.Transform qualified as Transform +import Geomancy.Vec4 qualified as Vec4 +import RIO.App (appEnv) +import Vulkan.Core10 qualified as Vk +import Vulkan.NamedType ((:::)) + +import Engine.Camera qualified as Camera +import Engine.Types qualified as Engine +import Engine.Worker qualified as Worker + +data Box = Box + { boxPosition :: Vec2 + , boxSize :: Vec2 + } + deriving (Eq, Ord, Show) + +data Alignment = Alignment + { alignX :: Origin -- ^ left/center/right + , alignY :: Origin -- ^ top/middle/bottom + } + +pattern LeftTop :: Alignment +pattern LeftTop = Alignment Begin Begin + +pattern LeftMiddle :: Alignment +pattern LeftMiddle = Alignment Begin Middle + +pattern LeftBottom :: Alignment +pattern LeftBottom = Alignment Begin End + +pattern CenterTop :: Alignment +pattern CenterTop = Alignment Middle Begin + +pattern Center :: Alignment +pattern Center = Alignment Middle Middle + +pattern CenterBottom :: Alignment +pattern CenterBottom = Alignment Middle End + +pattern RightTop :: Alignment +pattern RightTop = Alignment End Begin + +pattern RightMiddle :: Alignment +pattern RightMiddle = Alignment End Middle + +pattern RightBottom :: Alignment +pattern RightBottom = Alignment End End + +data Origin + = Begin + | Middle + | End + deriving (Eq, Ord, Show, Enum, Bounded) + +type BoxProcess = Worker.Merge Box + +trackScreen :: Engine.StageRIO st BoxProcess +trackScreen = do + projection <- asks $ Engine.ghScreenP . appEnv + Worker.spawnMerge1 mkBox (Worker.getInput projection) + where + mkBox Camera.ProjectionInput{projectionScreen} = Box + { boxPosition = 0 + , boxSize = vec2 (fromIntegral width) (fromIntegral height) + } + where + Vk.Extent2D{width, height} = projectionScreen + +padAbs + :: ( MonadUnliftIO m + , Worker.HasOutput parent + , Worker.GetOutput parent ~ Box + , Worker.HasOutput padding + , Worker.GetOutput padding ~ Vec4 + ) + => parent + -> padding + -> m BoxProcess +padAbs = Worker.spawnMerge2 boxPadAbs + +{-# INLINEABLE boxPadAbs #-} +boxPadAbs :: Box -> Vec4 -> Box +boxPadAbs Box{..} (WithVec4 top right bottom left) = Box + { boxPosition = boxPosition + vec2 dx dy + , boxSize = boxSize - vec2 dw dh + } + where + WithVec2 w h = boxSize + dx = left * 0.5 - right * 0.5 + dy = top * 0.5 - bottom * 0.5 + dw = min w (left + right) + dh = min h (top + bottom) + +padRel + :: ( MonadUnliftIO m + , Worker.HasOutput parent + , Worker.GetOutput parent ~ Box + , Worker.HasOutput padding + , Worker.GetOutput padding ~ Vec4 + ) + => parent + -> padding + -> m BoxProcess +padRel = Worker.spawnMerge2 boxPadRel + +{-# INLINEABLE boxPadRel #-} +boxPadRel :: Box -> Vec4 -> Box +boxPadRel box@Box{boxSize=WithVec2 w h} pad = + boxPadAbs box (pad * vec4 h w h w) + +fitPlaceAbs + :: ( MonadUnliftIO m + , Worker.HasOutput parent + , Worker.GetOutput parent ~ Box + ) + => Alignment + -> "dimensions" ::: Vec2 + -> parent + -> m BoxProcess +fitPlaceAbs align dimensions = + Worker.spawnMerge1 + (boxFitPlace align dimensions) + +{-# INLINEABLE boxFitPlace #-} +boxFitPlace + :: Alignment + -> "dimensions" ::: Vec2 + -> "parent" ::: Box + -> Box +boxFitPlace Alignment{..} wh parent = + boxPadAbs parent (vec4 t r b l) + where + (WithVec2 dw dh, _box) = boxFitScale wh parent + + (l, r) = case alignX of + Begin -> (0, dw) + Middle -> (dw / 2, dw / 2) + End -> (dw, 0) + + (t, b) = case alignY of + Begin -> (0, dh) + Middle -> (dh / 2, dh / 2) + End -> (dh, 0) + +{-# INLINEABLE boxFitScale #-} +boxFitScale + :: "dimensions" ::: Vec2 + -> "parent" ::: Box + -> ( "leftovers" ::: Vec2 + , Box + ) +boxFitScale (WithVec2 w h) parent = + ( vec2 (pw - sw) (ph - sh) + , Box + { boxSize = vec2 sw sh + , boxPosition = boxPosition parent + } + ) + where + Box{boxSize=WithVec2 pw ph} = parent + + sw = scale * w + sh = scale * h + + scale = + if parentAspect > aspect then + ph / h + else + pw / w + where + parentAspect = pw / ph + aspect = w / h + +splitsRelStatic + :: ( MonadUnliftIO m + , Worker.HasOutput parent + , Worker.GetOutput parent ~ Box + , Traversable t -- XXX: nested traversables may behave suprisingly + ) + => ((Float, Float) -> Vec4) + -> parent + -> t Float + -> m (t BoxProcess) +splitsRelStatic padF parentVar shares = + for (sharePads totalShares shares) \pads -> do + shareVar <- Worker.newVar $ padF pads Vec4.^/ totalShares + padRel parentVar shareVar + where + totalShares = sum shares + +sharePadsH :: (Float, Float) -> Vec4 +sharePadsH (left, right) = vec4 0 right 0 left + +sharePadsV :: (Float, Float) -> Vec4 +sharePadsV (top, bottom) = vec4 top 0 bottom 0 + +sharePads :: Traversable t => Float -> t Float -> t (Float, Float) +sharePads totalShares shares = snd $ mapAccumL f 0 shares + where + f sharesBefore share = + ( sharesBefore + share + , ( sharesBefore + , totalShares - sharesBefore - share + ) + ) + +hSplitRel + :: ( MonadUnliftIO m + , Worker.HasOutput parent + , Worker.GetOutput parent ~ Box + , Worker.HasOutput proportion + , Worker.GetOutput proportion ~ Float + ) + => parent + -> proportion + -> m (BoxProcess, BoxProcess) +hSplitRel parentVar proportionVar = (,) + <$> spawnLeft parentVar proportionVar + <*> spawnRight parentVar proportionVar + where + spawnLeft = Worker.spawnMerge2 \parent proportion -> + let + rightWidth = + withVec2 (boxSize parent) \width _height -> + width - width * proportion + in + boxPadAbs parent (vec4 0 rightWidth 0 0) + + spawnRight = Worker.spawnMerge2 \parent proportion -> + let + leftWidth = + withVec2 (boxSize parent) \width _height -> + width * proportion + in + boxPadAbs parent (vec4 0 0 0 leftWidth) + +vSplitRel + :: ( MonadUnliftIO m + , Worker.HasOutput parent + , Worker.GetOutput parent ~ Box + , Worker.HasOutput proportion + , Worker.GetOutput proportion ~ Float + ) + => parent + -> proportion + -> m (BoxProcess, BoxProcess) +vSplitRel parentVar proportionVar = (,) + <$> spawnTop parentVar proportionVar + <*> spawnBottom parentVar proportionVar + where + spawnTop = Worker.spawnMerge2 \parent proportion -> + let + bottomHeight = + withVec2 (boxSize parent) \_width height -> + height - height * proportion + in + boxPadAbs parent (vec4 0 0 bottomHeight 0) + + spawnBottom = Worker.spawnMerge2 \parent proportion -> + let + topHeight = + withVec2 (boxSize parent) \_width height -> + height * proportion + in + boxPadAbs parent (vec4 topHeight 0 0 0) + +{-# INLINEABLE boxRectAbs #-} +boxRectAbs :: Box -> Vk.Rect2D +boxRectAbs Box{..} = + withVec2 boxPosition \x y -> + withVec2 boxSize \w h -> + let + r = Vk.Rect2D + { offset = Vk.Offset2D (truncate $ x) (truncate $ y) -- FIXME: rects have top-left origin + , extent = Vk.Extent2D (truncate w) (truncate h) + } + in + -- traceShow (Box{..}, r) + r + +{-# INLINEABLE boxTransformAbs #-} +boxTransformAbs :: Box -> Transform +boxTransformAbs Box{..} = mconcat + [ withVec2 boxSize Transform.scaleXY + , withVec2 boxPosition translateXY + ] + +{-# INLINE translateXY #-} +translateXY :: Float -> Float -> Transform +translateXY x y = Transform.translate x y 0 + +whenInBoxP + :: ( MonadIO m + , Worker.HasOutput box + , Worker.GetOutput box ~ Box + ) + => "screen" ::: Vec2 + -> box + -> ("local" ::: Vec2 -> m ()) + -> m () +whenInBoxP cursorPos boxP action = do + box <- Worker.getOutputData boxP + when (pointInBox cursorPos box) $ + action $ cursorPos - boxPosition box + +pointInBox :: Vec2 -> Box -> Bool +pointInBox point Box{..} = + withVec2 point \px py -> + withVec2 boxPosition \bx by -> + withVec2 boxSize \w h -> + let + halfWidth = w / 2 + halfHeight = h / 2 + left = bx - halfWidth + right = bx + halfWidth + top = by - halfHeight + bottom = by + halfHeight + in + px >= left && + px <= right && + py >= top && + py <= bottom diff --git a/src/Engine/Vulkan/DescSets.hs b/src/Engine/Vulkan/DescSets.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Vulkan/DescSets.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE UndecidableInstances #-} + +-- XXX: TypeError in Compatible generates unused constraint argument +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Engine.Vulkan.DescSets + ( HasDescSet(..) + + , Bound(..) + , withBoundDescriptorSets0 + + , Compatible + + , Extend + , extendDS + + , Tagged(..) + ) where + +import RIO + +import Data.Kind (Constraint, Type) +import Data.Tagged (Tagged(..)) +import GHC.TypeLits as Type +import Vulkan.Core10 qualified as Vk + +import Engine.Types (Frame(fRecycledResources), RecycledResources(rrData)) +import Engine.Vulkan.Types (Bound(..)) + +class HasDescSet tag a where + getDescSet :: a -> Tagged tag Vk.DescriptorSet + +instance HasDescSet tag rr => HasDescSet tag (RecycledResources rr) where + {-# INLINE getDescSet #-} + getDescSet = getDescSet . rrData + +instance HasDescSet tag rr => HasDescSet tag (Frame rp p rr) where + {-# INLINE getDescSet #-} + getDescSet = getDescSet . fRecycledResources + +instance HasDescSet tag rr => HasDescSet tag (env, Frame rp p rr) where + {-# INLINE getDescSet #-} + getDescSet = getDescSet . snd + +{-# INLINE withBoundDescriptorSets0 #-} +withBoundDescriptorSets0 + :: MonadIO m + => Vk.CommandBuffer + -> Vk.PipelineBindPoint + -> Tagged dsl Vk.PipelineLayout + -> Tagged dsl (Vector Vk.DescriptorSet) + -> Bound dsl Void Void m b + -> m b +withBoundDescriptorSets0 cb pbp (Tagged layout) (Tagged descriptorSets) (Bound action) = do + Vk.cmdBindDescriptorSets + cb + pbp + layout + 0 + descriptorSets + mempty + + action + +type Compatible (smaller :: [Type]) (larger :: [Type]) = Compatible' smaller larger smaller larger + +type family Compatible' (xs :: [Type]) (ys :: [Type]) (a :: [Type]) (b :: [Type]) :: Constraint where + Compatible' '[] _ _ _ = () + Compatible' (x : xs) (x : ys) a b = Compatible' xs ys a b + Compatible' _ _ a b = TypeError + ( 'ShowType a ':<>: 'Text " isn't compatible prefix of " ':<>: 'ShowType b + ) + +type family Extend (xs :: [Type]) y :: [Type] where + Extend '[] y = '[y] + Extend (x ': xs) y = x ': Extend xs y + +extendDS + :: Tagged (as :: [Type]) (Vector Vk.DescriptorSet) + -> Tagged b Vk.DescriptorSet + -> Tagged (Extend as b) (Vector Vk.DescriptorSet) +extendDS (Tagged xs) (Tagged y) = Tagged (xs <> [y]) diff --git a/src/Engine/Vulkan/Pipeline.hs b/src/Engine/Vulkan/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Vulkan/Pipeline.hs @@ -0,0 +1,416 @@ +-- XXX: TypeError in Compatible generates unused constraint argument +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Engine.Vulkan.Pipeline + ( Pipeline(..) + , Config(..) + , allocate + , bind + + , pushPlaceholder + + , vertexInput + , attrBindings + , formatSize + ) where + +import RIO + +import Data.Bits ((.|.)) +import Data.Kind (Type) +import Data.List qualified as List +import Data.Tagged (Tagged(..)) +import Data.Vector qualified as Vector +import UnliftIO.Resource (MonadResource, ReleaseKey) +import UnliftIO.Resource qualified as Resource +import Vulkan.Core10 qualified as Vk +import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12 +import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&)) +import Vulkan.NamedType ((:::)) +import Vulkan.Zero (Zero(..)) + +import Engine.Vulkan.DescSets (Bound(..), Compatible) +import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), MonadVulkan, DsBindings, DsLayouts, getPipelineCache) + +data Pipeline (dsl :: [Type]) vertices instances = Pipeline + { pipeline :: Vk.Pipeline + , pLayout :: Tagged dsl Vk.PipelineLayout + , pDescLayouts :: Tagged dsl DsLayouts + } + +-- * Pipeline + +data Config (dsl :: [Type]) vertices instances = Config + { cVertexCode :: Maybe ByteString + , cFragmentCode :: Maybe ByteString + , cVertexInput :: SomeStruct Vk.PipelineVertexInputStateCreateInfo + , cDescLayouts :: Tagged dsl [DsBindings] + , cPushConstantRanges :: Vector Vk.PushConstantRange + , cBlend :: Bool + , cDepthWrite :: Bool + , cDepthTest :: Bool + , cTopology :: Vk.PrimitiveTopology + , cCull :: Vk.CullModeFlagBits + , cDepthBias :: Maybe ("constant" ::: Float, "slope" ::: Float) + } + +instance Zero (Config dsl vertices instances) where + zero = Config + { cVertexCode = Nothing + , cFragmentCode = Nothing + , cVertexInput = zero + , cDescLayouts = Tagged [] -- FIXME: unsafe wrt. "dsl" + , cPushConstantRanges = mempty + , cBlend = False + , cDepthWrite = True + , cDepthTest = True + , cTopology = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST + , cCull = Vk.CULL_MODE_BACK_BIT + , cDepthBias = Nothing + } + +-- XXX: consider using instance attrs or uniforms +pushPlaceholder :: Vk.PushConstantRange +pushPlaceholder = Vk.PushConstantRange + { Vk.stageFlags = Vk.SHADER_STAGE_VERTEX_BIT .|. Vk.SHADER_STAGE_FRAGMENT_BIT + , Vk.offset = 0 + , Vk.size = 4 * dwords + } + where + -- XXX: each 4 word32s eat up one register (on AMD) + dwords = 4 + +allocate + :: ( MonadVulkan env m + , MonadResource m + , HasRenderPass renderpass + ) + => Maybe Vk.Extent2D + -> Vk.SampleCountFlagBits + -> Config dsl vertices instances + -> renderpass + -> m (ReleaseKey, Pipeline dsl vertices instances) +allocate extent msaa config renderpass = do + ctx <- ask + Resource.allocate + (create ctx extent msaa renderpass config) + (destroy ctx) + +create + :: (MonadIO io, HasVulkan ctx, HasRenderPass renderpass) + => ctx + -> Maybe Vk.Extent2D + -> Vk.SampleCountFlagBits + -> renderpass + -> Config dsl vertices instances + -> io (Pipeline dsl vertices instances) +create context mextent msaa renderpass Config{..} = do + dsLayouts <- Vector.forM (Vector.fromList $ unTagged cDescLayouts) \bindsFlags -> do + let + (binds, flags) = List.unzip bindsFlags + + setCI = + zero + { Vk.bindings = Vector.fromList binds + } + ::& zero + { Vk12.bindingFlags = Vector.fromList flags + } + :& () + + Vk.createDescriptorSetLayout device setCI Nothing + + -- TODO: get from outside + layout <- Vk.createPipelineLayout device (layoutCI dsLayouts) Nothing + + let + codeStages = Vector.fromList $ case (cVertexCode, cFragmentCode) of + (Just vertCode, Just fragCode) -> + [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode) + , (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode) + ] + + (Just vertCode, Nothing) -> + [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode) + ] + + (Nothing, Just fragCode) -> + -- XXX: good luck + [ (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode) + ] + + (Nothing, Nothing) -> + [] + shader <- createShader context codeStages + + let + cis = Vector.singleton . SomeStruct $ + pipelineCI (sPipelineStages shader) layout + + Vk.createGraphicsPipelines device cache cis Nothing >>= \case + (Vk.SUCCESS, pipelines) -> + case Vector.toList pipelines of + [one] -> do + destroyShader context shader + pure Pipeline + { pipeline = one + , pLayout = Tagged layout + , pDescLayouts = Tagged dsLayouts + } + _ -> + error "assert: exactly one pipeline requested" + (err, _) -> + error $ "createGraphicsPipelines: " <> show err + where + device = getDevice context + cache = getPipelineCache context + + layoutCI dsLayouts = Vk.PipelineLayoutCreateInfo + { flags = zero + , setLayouts = dsLayouts + , pushConstantRanges = cPushConstantRanges + } + + pipelineCI stages layout = zero + { Vk.stages = stages + , Vk.vertexInputState = Just cVertexInput + , Vk.inputAssemblyState = Just inputAsembly + , Vk.viewportState = Just $ SomeStruct viewportState + , Vk.rasterizationState = SomeStruct rasterizationState + , Vk.multisampleState = Just $ SomeStruct multisampleState + , Vk.depthStencilState = Just depthStencilState + , Vk.colorBlendState = Just $ SomeStruct colorBlendState + , Vk.dynamicState = dynamicState + , Vk.layout = layout + , Vk.renderPass = getRenderPass renderpass + , Vk.subpass = 0 + , Vk.basePipelineHandle = zero + } + where + inputAsembly = zero + { Vk.topology = cTopology + , Vk.primitiveRestartEnable = restartable + } + + restartable = elem cTopology + [ Vk.PRIMITIVE_TOPOLOGY_LINE_STRIP + , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_STRIP + , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_FAN + ] + + (viewportState, dynamicState) = case mextent of + Nothing -> + ( zero + { Vk.viewportCount = 1 + , Vk.scissorCount = 1 + } + , Just zero + { Vk.dynamicStates = Vector.fromList + [ Vk.DYNAMIC_STATE_VIEWPORT + , Vk.DYNAMIC_STATE_SCISSOR + ] + } + ) + Just extent@Vk.Extent2D{width, height} -> + ( zero + { Vk.viewports = Vector.fromList + [ Vk.Viewport + { Vk.x = 0 + , Vk.y = 0 + , Vk.width = realToFrac width + , Vk.height = realToFrac height + , Vk.minDepth = 0 + , Vk.maxDepth = 1 + } + ] + , Vk.scissors = Vector.singleton Vk.Rect2D + { Vk.offset = Vk.Offset2D 0 0 + , extent = extent + } + } + , Nothing + ) + + rasterizationState = case cDepthBias of + Nothing -> + rasterizationBase + Just (constantFactor, slopeFactor) -> + rasterizationBase + { Vk.depthBiasEnable = True + , Vk.depthBiasConstantFactor = constantFactor + , Vk.depthBiasSlopeFactor = slopeFactor + } + + rasterizationBase = zero + { Vk.depthClampEnable = False + , Vk.rasterizerDiscardEnable = False + , Vk.lineWidth = 1 + , Vk.polygonMode = Vk.POLYGON_MODE_FILL + , Vk.cullMode = cCull + , Vk.frontFace = Vk.FRONT_FACE_CLOCKWISE + , Vk.depthBiasEnable = False + } + + multisampleState = zero + { Vk.rasterizationSamples = msaa + , Vk.sampleShadingEnable = enable + , Vk.minSampleShading = if enable then 0.2 else 1.0 + , Vk.sampleMask = Vector.singleton maxBound + } + where + enable = True -- TODO: check and enable sample rate shading feature + + depthStencilState = zero + { Vk.depthTestEnable = cDepthTest + , Vk.depthWriteEnable = cDepthWrite + , Vk.depthCompareOp = Vk.COMPARE_OP_LESS + , Vk.depthBoundsTestEnable = False + , Vk.minDepthBounds = 0.0 -- Optional + , Vk.maxDepthBounds = 1.0 -- Optional + , Vk.stencilTestEnable = False + , Vk.front = zero -- Optional + , Vk.back = zero -- Optional + } + + colorBlendState = zero + { Vk.logicOpEnable = + False + , Vk.attachments = Vector.singleton zero + { Vk.blendEnable = cBlend + , Vk.srcColorBlendFactor = Vk.BLEND_FACTOR_ONE + , Vk.dstColorBlendFactor = Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA + , Vk.colorBlendOp = Vk.BLEND_OP_ADD + , Vk.srcAlphaBlendFactor = Vk.BLEND_FACTOR_ONE + , Vk.dstAlphaBlendFactor = Vk.BLEND_FACTOR_ONE_MINUS_SRC_ALPHA + , Vk.alphaBlendOp = Vk.BLEND_OP_ADD + , Vk.colorWriteMask = colorRgba + } + } + + colorRgba = + Vk.COLOR_COMPONENT_R_BIT .|. + Vk.COLOR_COMPONENT_G_BIT .|. + Vk.COLOR_COMPONENT_B_BIT .|. + Vk.COLOR_COMPONENT_A_BIT + +destroy :: (MonadIO io, HasVulkan ctx) => ctx -> Pipeline dsl vertices instances -> io () +destroy context Pipeline{..} = do + Vector.forM_ (unTagged pDescLayouts) \dsLayout -> + Vk.destroyDescriptorSetLayout device dsLayout Nothing + Vk.destroyPipeline device pipeline Nothing + Vk.destroyPipelineLayout device (unTagged pLayout) Nothing + where + device = getDevice context + +bind + :: ( Compatible pipeLayout boundLayout + , MonadIO m + ) + => Vk.CommandBuffer + -> Pipeline pipeLayout vertices instances + -> Bound boundLayout vertices instances m () + -> Bound boundLayout oldVertices oldInstances m () +bind cb Pipeline{pipeline} (Bound attrAction) = do + Bound $ Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_GRAPHICS pipeline + Bound attrAction + +vertexInput :: [(Vk.VertexInputRate, [Vk.Format])] -> SomeStruct Vk.PipelineVertexInputStateCreateInfo +vertexInput bindings = SomeStruct zero + { Vk.vertexBindingDescriptions = binds + , Vk.vertexAttributeDescriptions = attrs + } + where + binds = Vector.fromList do + (ix, (rate, formats)) <- zip [0..] bindings + pure Vk.VertexInputBindingDescription + { binding = ix + , stride = sum $ map formatSize formats + , inputRate = rate + } + + attrs = attrBindings $ map snd bindings + +-- * Shader code + +data Shader = Shader + { sModules :: Vector Vk.ShaderModule + , sPipelineStages :: Vector (SomeStruct Vk.PipelineShaderStageCreateInfo) + } + +createShader + :: (MonadIO io, HasVulkan ctx) + => ctx + -> Vector (Vk.ShaderStageFlagBits, ByteString) + -> io Shader +createShader context stages = do + staged <- Vector.forM stages \(stage, code) -> do + module_ <- Vk.createShaderModule + (getDevice context) + zero + { Vk.code = code + } + Nothing + pure + ( module_ + , SomeStruct zero + { Vk.stage = stage + , Vk.module' = module_ + , Vk.name = "main" + -- , Vk.specializationInfo = Nothing + } + ) + let (modules, pStages) = Vector.unzip staged + pure Shader + { sModules = modules + , sPipelineStages = pStages + } + +destroyShader :: (MonadIO io, HasVulkan ctx) => ctx -> Shader -> io () +destroyShader context Shader{sModules} = + Vector.forM_ sModules \module_ -> + Vk.destroyShaderModule (getDevice context) module_ Nothing + +-- * Utils + +attrBindings :: [[Vk.Format]] -> Vector Vk.VertexInputAttributeDescription +attrBindings bindings = mconcat $ List.unfoldr shiftLocations (0, 0, bindings) + where + shiftLocations = \case + (_binding, _lastLoc, []) -> Nothing + (binding, lastLoc, formats : rest) -> Just (bound, next) + where + bound = Vector.fromList do + (ix, format) <- zip [0..] formats + let offset = sum . map formatSize $ take ix formats + pure zero + { Vk.binding = binding + , Vk.location = fromIntegral $ lastLoc + ix + , Vk.format = format + , Vk.offset = offset + } + + next = + ( binding + 1 + , lastLoc + Vector.length bound + , rest + ) + +formatSize :: Integral a => Vk.Format -> a +formatSize = \case + Vk.FORMAT_R32G32B32A32_SFLOAT -> 16 + Vk.FORMAT_R32G32B32_SFLOAT -> 12 + Vk.FORMAT_R32G32_SFLOAT -> 8 + Vk.FORMAT_R32_SFLOAT -> 4 + + Vk.FORMAT_R32G32B32A32_UINT -> 16 + Vk.FORMAT_R32G32B32_UINT -> 12 + Vk.FORMAT_R32G32_UINT -> 8 + Vk.FORMAT_R32_UINT -> 4 + + Vk.FORMAT_R32G32B32A32_SINT -> 16 + Vk.FORMAT_R32G32B32_SINT -> 12 + Vk.FORMAT_R32G32_SINT -> 8 + Vk.FORMAT_R32_SINT -> 4 + + format -> + error $ "Format size unknown: " <> show format diff --git a/src/Engine/Vulkan/Swapchain.hs b/src/Engine/Vulkan/Swapchain.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Vulkan/Swapchain.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE OverloadedLists #-} + +module Engine.Vulkan.Swapchain + ( SwapchainResources(..) + , SwapchainInfo(..) + , allocSwapchainResources + , recreateSwapchainResources + , createSwapchain + , threwSwapchainError + + , HasSwapchain(..) + + , setDynamic + , setDynamicFullscreen + ) where + +import RIO + +import Data.Bits (zeroBits, (.&.), (.|.)) +import RIO.Vector qualified as V +import UnliftIO.Resource (MonadResource, allocate, release) +import UnliftIO.Resource qualified as Resource +import Vulkan.Core10 qualified as Vk +import Vulkan.Exception (VulkanException(..)) +import Vulkan.Extensions.VK_KHR_surface qualified as Khr +import Vulkan.Extensions.VK_KHR_swapchain qualified as Khr +import Vulkan.Utils.Misc ((.&&.)) +import Vulkan.NamedType ((:::)) +import Vulkan.Zero (zero) + +import Engine.Camera qualified as Camera +import Engine.Types.RefCounted (RefCounted, newRefCounted, releaseRefCounted) +import Engine.Vulkan.Types (MonadVulkan, HasVulkan(..), HasSwapchain(..), pdiProperties) +import Engine.Worker qualified as Worker + +data SwapchainResources = SwapchainResources + { srInfo :: SwapchainInfo + , srImageViews :: Vector Vk.ImageView + , srImages :: Vector Vk.Image + , srRelease :: RefCounted + , srProjection :: Camera.ProjectionProcess + } + +data SwapchainInfo = SwapchainInfo + { siSwapchain :: Khr.SwapchainKHR + , siSwapchainReleaseKey :: Resource.ReleaseKey + , siPresentMode :: Khr.PresentModeKHR + , siMinImageCount :: Word32 + , siSurfaceFormat :: Vk.Format + , siSurfaceColorspace :: Khr.ColorSpaceKHR + , siDepthFormat :: Vk.Format + , siMultisample :: Vk.SampleCountFlagBits + , siAnisotropy :: Float + , siImageExtent :: Vk.Extent2D + , siSurface :: Khr.SurfaceKHR + } + +instance HasSwapchain SwapchainResources where + getSurfaceExtent = siImageExtent . srInfo + getSurfaceFormat = siSurfaceFormat . srInfo + getDepthFormat = siDepthFormat . srInfo + getMultisample = siMultisample . srInfo + getAnisotropy = siAnisotropy . srInfo + getSwapchainViews = srImageViews + getMinImageCount = siMinImageCount . srInfo + getImageCount = fromIntegral . V.length . srImages + +-- | Allocate everything which depends on the swapchain +allocSwapchainResources + :: ( MonadResource (RIO env) + , HasVulkan env + , HasLogFunc env + ) + => Khr.SwapchainKHR + -- ^ Previous swapchain, can be NULL_HANDLE + -> Vk.Extent2D + -- ^ If the swapchain size determines the surface size, use this size + -> Khr.SurfaceKHR + -> Camera.ProjectionProcess + -> RIO env SwapchainResources + -- -> ResourceT (RIO env) SwapchainResources +allocSwapchainResources oldSwapchain windowSize surface projectionP = do + logDebug "Allocating swapchain resources" + + device <- asks getDevice + info@SwapchainInfo{..} <- createSwapchain oldSwapchain windowSize surface + + -- XXX: Get all the swapchain images, and create views for them + (_, swapchainImages) <- Khr.getSwapchainImagesKHR device siSwapchain + res <- for swapchainImages $ + createImageView siSurfaceFormat + let (imageViewKeys, imageViews) = V.unzip res + + -- XXX: This refcount is released in 'recreateSwapchainResources' + releaseDebug <- toIO $ logDebug "Releasing swapchain resources" + releaseResources <- newRefCounted $ do + releaseDebug + traverse_ release imageViewKeys + release siSwapchainReleaseKey + + Worker.pushInput projectionP \input -> input + { Camera.projectionScreen = windowSize + } + + pure SwapchainResources + { srInfo = info + , srImageViews = imageViews + , srImages = swapchainImages + , srRelease = releaseResources + , srProjection = projectionP + } + +recreateSwapchainResources + :: ( MonadResource (RIO env) + , HasVulkan env + , HasLogFunc env + ) + => Vk.Extent2D + -> SwapchainResources + -- ^ The reference to these resources will be dropped + -> RIO env SwapchainResources +recreateSwapchainResources windowSize oldResources = do + sr <- allocSwapchainResources + (siSwapchain $ srInfo oldResources) + windowSize + (siSurface $ srInfo oldResources) + (srProjection oldResources) + releaseRefCounted (srRelease oldResources) + pure sr + +-- | Create a swapchain from a 'SurfaceKHR' +createSwapchain + :: ( MonadResource m + , MonadVulkan env m + , HasLogFunc env + ) + => Khr.SwapchainKHR + -- ^ Old swapchain, can be NULL_HANDLE + -> Vk.Extent2D + -- ^ If the swapchain size determines the surface size, use this size + -> Khr.SurfaceKHR + -> m SwapchainInfo +createSwapchain oldSwapchain explicitSize surf = do + physical <- asks getPhysicalDevice + device <- asks getDevice + props <- asks $ pdiProperties . getPhysicalDeviceInfo + surfaceCaps <- Khr.getPhysicalDeviceSurfaceCapabilitiesKHR physical surf + + logDebug $ displayShow surfaceCaps + + -- Check flags + for_ requiredUsageFlags \flag -> + unless (Khr.supportedUsageFlags surfaceCaps .&&. flag) do + logError $ "Surface images do not support " <> displayShow flag + throwString $ "Surface images do not support " <> show flag + + -- Select a present mode + (_, availablePresentModes) <- Khr.getPhysicalDeviceSurfacePresentModesKHR physical surf + presentMode <- + case filter (`V.elem` availablePresentModes) desiredPresentModes of + [] -> do + logError "Unable to find a suitable present mode for swapchain" + throwString "Unable to find a suitable present mode for swapchain" + x : _rest -> + pure x + + -- Select a surface format + -- getPhysicalDeviceSurfaceFormatsKHR doesn't return an empty list + -- (_, availableFormats) <- Khr.getPhysicalDeviceSurfaceFormatsKHR physical surf + surfaceFormatKhr <- getSurfaceFormatKhr physical surf preferSrgb + + depthFormat <- getDepthFormats physical preferStenciledDepth >>= \case + fmt : _rest -> + pure fmt + _none -> + throwString "Unable to find a suitable depth format" + + -- Calculate the extent + let + imageExtent = + case Khr.currentExtent (surfaceCaps :: Khr.SurfaceCapabilitiesKHR) of + Vk.Extent2D w h | w == maxBound, h == maxBound -> + explicitSize + extent -> + extent + + let + minImageCount = + let + limit = case Khr.maxImageCount (surfaceCaps :: Khr.SurfaceCapabilitiesKHR) of + 0 -> maxBound + n -> n + -- Request one additional image to prevent us having to wait for + -- the driver to finish + buffer = 1 + desired = + buffer + Khr.minImageCount (surfaceCaps :: Khr.SurfaceCapabilitiesKHR) + in + min limit desired + + let compositeAlphaMode = Khr.COMPOSITE_ALPHA_OPAQUE_BIT_KHR + unless (compositeAlphaMode .&&. Khr.supportedCompositeAlpha surfaceCaps) $ + throwString $ "Surface doesn't support " <> show compositeAlphaMode + + let + Khr.SurfaceFormatKHR{colorSpace=surfaceColorspace, format=surfaceFormat} = surfaceFormatKhr + swapchainCreateInfo = Khr.SwapchainCreateInfoKHR + { surface = surf + , next = () + , flags = zero + , queueFamilyIndices = mempty -- No need to specify when not using concurrent access + , minImageCount = minImageCount + , imageFormat = surfaceFormat + , imageColorSpace = surfaceColorspace + , imageExtent = imageExtent + , imageArrayLayers = 1 + , imageUsage = foldr (.|.) zero requiredUsageFlags + , imageSharingMode = Vk.SHARING_MODE_EXCLUSIVE + , preTransform = Khr.currentTransform (surfaceCaps :: Khr.SurfaceCapabilitiesKHR) + , compositeAlpha = compositeAlphaMode + , presentMode = presentMode + , clipped = True + , oldSwapchain = oldSwapchain + } + + logDebug $ "Creating swapchain from " <> displayShow swapchainCreateInfo + (key, swapchain) <- Khr.withSwapchainKHR device swapchainCreateInfo Nothing allocate + + pure SwapchainInfo + { siSwapchain = swapchain + , siSwapchainReleaseKey = key + , siPresentMode = presentMode + , siMinImageCount = minImageCount + , siSurface = surf + , siSurfaceFormat = surfaceFormat + , siSurfaceColorspace = surfaceColorspace + , siDepthFormat = depthFormat + , siMultisample = msaaSamples props + , siAnisotropy = Vk.maxSamplerAnisotropy (Vk.limits props) + , siImageExtent = imageExtent + } + +-- -- The vector passed will have at least one element +-- selectSurfaceFormat :: Vector Khr.SurfaceFormatKHR -> Khr.SurfaceFormatKHR +-- selectSurfaceFormat = V.maximumBy (comparing surfaceFormatScore) +-- where +-- -- An ordered list of formats to choose for the swapchain images, if none +-- -- match then the first available format will be chosen. +-- surfaceFormatScore :: Khr.SurfaceFormatKHR -> Int +-- surfaceFormatScore = \case +-- _ -> 0 + +getSurfaceFormatKhr + :: MonadIO io + => Vk.PhysicalDevice + -> Khr.SurfaceKHR + -> Khr.SurfaceFormatKHR + -> io Khr.SurfaceFormatKHR +getSurfaceFormatKhr device surface desiredFormat = do + (_res, formats) <- Khr.getPhysicalDeviceSurfaceFormatsKHR device surface + pure case toList formats of + [] -> + desiredFormat + [Khr.SurfaceFormatKHR Vk.FORMAT_UNDEFINED _colorSpace] -> + desiredFormat + candidates | any cond candidates -> + desiredFormat + whatever : _rest -> + whatever + where + cond f = + Khr.format f == Khr.format desiredFormat && + Khr.colorSpace f == Khr.colorSpace desiredFormat + +preferSrgb :: Khr.SurfaceFormatKHR +preferSrgb = + Khr.SurfaceFormatKHR + Vk.FORMAT_B8G8R8A8_SRGB + Khr.COLOR_SPACE_SRGB_NONLINEAR_KHR + +getDepthFormats + :: MonadIO io + => Vk.PhysicalDevice + -> [Vk.Format] + -> io [Vk.Format] +getDepthFormats device desiredDepthFormats = do + properties <- traverse (Vk.getPhysicalDeviceFormatProperties device) desiredDepthFormats + pure do + (format, props) <- zip desiredDepthFormats properties + guard $ + Vk.optimalTilingFeatures props .&&. Vk.FORMAT_FEATURE_DEPTH_STENCIL_ATTACHMENT_BIT + pure format + +preferStenciledDepth :: [Vk.Format] +preferStenciledDepth = + [ Vk.FORMAT_D32_SFLOAT_S8_UINT + , Vk.FORMAT_D24_UNORM_S8_UINT + , Vk.FORMAT_D32_SFLOAT + ] + +msaaSamples :: Vk.PhysicalDeviceProperties -> Vk.SampleCountFlagBits +msaaSamples Vk.PhysicalDeviceProperties{limits} = + case samplesAvailable of + [] -> + Vk.SAMPLE_COUNT_1_BIT + best : _rest -> + best + where + counts = + Vk.framebufferColorSampleCounts limits .&. + Vk.framebufferDepthSampleCounts limits + + samplesAvailable = do + countBit <- msaaCandidates + guard $ (counts .&. countBit) /= zeroBits + pure countBit + +msaaCandidates :: [Vk.SampleCountFlagBits] +msaaCandidates = + {- + XXX: Also possible, but not that impactful: 16x, 8x. + + Khronos MSAA best practice says: + Use 4x MSAA if possible; it's not expensive and provides good image quality improvements. + -} + [ Vk.SAMPLE_COUNT_4_BIT + , Vk.SAMPLE_COUNT_2_BIT + ] + +-- | An ordered list of the present mode to be chosen for the swapchain. +desiredPresentModes :: [Khr.PresentModeKHR] +desiredPresentModes = + [ Khr.PRESENT_MODE_FIFO_RELAXED_KHR + , Khr.PRESENT_MODE_FIFO_KHR -- ^ This will always be present + , Khr.PRESENT_MODE_IMMEDIATE_KHR -- ^ Keep this here for easy swapping for testing + ] + +-- | The images in the swapchain must support these flags. +requiredUsageFlags :: [Vk.ImageUsageFlagBits] +requiredUsageFlags = + [ Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT + -- , Vk.IMAGE_USAGE_STORAGE_BIT + ] + +-- | Catch an ERROR_OUT_OF_DATE_KHR exception and return 'True' if that happened +threwSwapchainError :: MonadUnliftIO f => f () -> f Bool +threwSwapchainError = fmap isLeft . tryJust swapchainError + where + swapchainError = \case + VulkanException e@Vk.ERROR_OUT_OF_DATE_KHR -> + Just e + + VulkanException Vk.ERROR_SURFACE_LOST_KHR -> + error "TODO: handle ERROR_SURFACE_LOST_KHR" + + VulkanException _ -> + Nothing + +-- | Create a pretty vanilla ImageView covering the whole image +createImageView + :: ( MonadResource m + , MonadVulkan env m + ) + => Vk.Format + -> Vk.Image + -> m (Resource.ReleaseKey, Vk.ImageView) +createImageView format image = do + device <- asks getDevice + Vk.withImageView device imageViewCI Nothing allocate + where + imageViewCI = zero + { Vk.image = image + , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D + , Vk.format = format + -- , Vk.components = zero + , Vk.subresourceRange = zero + { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , Vk.baseMipLevel = 0 + , Vk.levelCount = 1 + , Vk.baseArrayLayer = 0 + , Vk.layerCount = 1 + } + } + +setDynamic + :: MonadIO io + => Vk.CommandBuffer + -> "viewport" ::: Vk.Rect2D + -> "scissor" ::: Vk.Rect2D + -> io () +setDynamic cb viewrect scissor = do + Vk.cmdSetViewport cb 0 [viewport] + Vk.cmdSetScissor cb 0 [scissor] + where + viewport = Vk.Viewport + { x = realToFrac x + , y = realToFrac y + , width = realToFrac width + , height = realToFrac height + , minDepth = 0 + , maxDepth = 1 + } + where + Vk.Offset2D{x, y} = offset + Vk.Extent2D{width, height} = extent + Vk.Rect2D{offset, extent} = viewrect + +setDynamicFullscreen :: MonadIO io => Vk.CommandBuffer -> SwapchainResources -> io () +setDynamicFullscreen cb sr = do + Vk.cmdSetViewport cb + 0 + [ Vk.Viewport + { x = 0 + , y = 0 + , width = realToFrac width + , height = realToFrac height + , minDepth = 0 + , maxDepth = 1 + } + ] + Vk.cmdSetScissor cb 0 + [ Vk.Rect2D + { offset = Vk.Offset2D 0 0 + , extent = siImageExtent + } + ] + where + SwapchainResources{srInfo} = sr + SwapchainInfo{siImageExtent} = srInfo + Vk.Extent2D{width, height} = siImageExtent diff --git a/src/Engine/Vulkan/Types.hs b/src/Engine/Vulkan/Types.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Vulkan/Types.hs @@ -0,0 +1,140 @@ +module Engine.Vulkan.Types + ( MonadVulkan + , HasVulkan(..) + , getPipelineCache + + , HasSwapchain(..) + , HasRenderPass(..) + , RenderPass(..) + + , PhysicalDeviceInfo(..) + , Queues(..) + + , DsLayouts + , DsBindings + + , Bound(..) + ) where + +import RIO + +import Data.Kind (Type) +import RIO.App (App(..)) +import UnliftIO.Resource (MonadResource, ResourceT) +import Vulkan.Core10 qualified as Vk +import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12 +import Vulkan.NamedType ((:::)) +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..)) +import VulkanMemoryAllocator qualified as VMA + +type MonadVulkan env m = + ( MonadUnliftIO m + , MonadReader env m + , HasVulkan env + ) + +-- | A class for Monads which can provide some Vulkan handles +class HasVulkan a where + getInstance :: a -> Vk.Instance + getQueues :: a -> Queues (QueueFamilyIndex, Vk.Queue) + getPhysicalDevice :: a -> Vk.PhysicalDevice + getPhysicalDeviceInfo :: a -> PhysicalDeviceInfo + getDevice :: a -> Vk.Device + getAllocator :: a -> VMA.Allocator + +instance HasVulkan env => HasVulkan (App env st) where + getInstance = getInstance . appEnv + getQueues = getQueues . appEnv + getPhysicalDevice = getPhysicalDevice . appEnv + getPhysicalDeviceInfo = getPhysicalDeviceInfo . appEnv + getDevice = getDevice . appEnv + getAllocator = getAllocator . appEnv + +instance (HasVulkan env) => HasVulkan (env, a) where + getInstance = getInstance . fst + getQueues = getQueues . fst + getPhysicalDevice = getPhysicalDevice . fst + getPhysicalDeviceInfo = getPhysicalDeviceInfo . fst + getDevice = getDevice . fst + getAllocator = getAllocator . fst + +instance (HasSwapchain context) => HasSwapchain (a, context) where + getSurfaceExtent = getSurfaceExtent . snd + getSurfaceFormat = getSurfaceFormat . snd + getDepthFormat = getDepthFormat . snd + getMultisample = getMultisample . snd + getAnisotropy = getAnisotropy . snd + getSwapchainViews = getSwapchainViews . snd + getMinImageCount = getMinImageCount . snd + getImageCount = getImageCount . snd + +-- TODO +getPipelineCache :: {- HasVulkan ctx => -} ctx -> Vk.PipelineCache +getPipelineCache _ctx = Vk.NULL_HANDLE + +{- | + The shape of all the queues we use for our program, parameterized over the + queue type so we can use it with 'Vulkan.Utils.QueueAssignment.assignQueues'. +-} +data Queues q = Queues + { qGraphics :: q + , qTransfer :: q + , qCompute :: q + } + deriving (Show, Functor, Foldable, Traversable) + +data PhysicalDeviceInfo = PhysicalDeviceInfo + { pdiTotalMemory :: Word64 + , pdiQueueCreateInfos :: Vector (Vk.DeviceQueueCreateInfo '[]) + , pdiName :: Text + , pdiProperties :: Vk.PhysicalDeviceProperties + , pdiGetQueues :: Vk.Device -> IO (Queues (QueueFamilyIndex, Vk.Queue)) + } + +class HasSwapchain a where + getSurfaceExtent :: a -> Vk.Extent2D + getSurfaceFormat :: a -> Vk.Format + getDepthFormat :: a -> Vk.Format + getMultisample :: a -> Vk.SampleCountFlagBits + getAnisotropy :: a -> "max sampler anisotropy" ::: Float + getSwapchainViews :: a -> Vector Vk.ImageView + getMinImageCount :: a -> Word32 + getImageCount :: a -> Word32 + +-- TODO: extract to a module +class HasRenderPass a where + getFramebuffers :: a -> Vector Vk.Framebuffer + getRenderPass :: a -> Vk.RenderPass + getClearValues :: a -> Vector Vk.ClearValue + getRenderArea :: a -> Vk.Rect2D + +class RenderPass a where + allocateRenderpass_ + :: ( HasLogFunc env + , HasSwapchain context + , HasVulkan env + , MonadResource (RIO env) + ) + => context + -> ResourceT (RIO env) a + + updateRenderpass + :: ( HasLogFunc env + , HasSwapchain context + , HasVulkan env + , MonadResource (RIO env) + ) + => context + -> a + -> RIO env a + + refcountRenderpass + :: MonadResource (RIO env) + => a + -> RIO env () + +type DsBindings = [(Vk.DescriptorSetLayoutBinding, Vk12.DescriptorBindingFlags)] +type DsLayouts = Vector Vk.DescriptorSetLayout + +newtype Bound (dsl :: [Type]) vertices instances m a = Bound (m a) + deriving (Foldable, Traversable, Functor, Applicative, Monad, MonadIO, MonadUnliftIO) diff --git a/src/Engine/Window/CursorPos.hs b/src/Engine/Window/CursorPos.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Window/CursorPos.hs @@ -0,0 +1,34 @@ +module Engine.Window.CursorPos + ( Callback + , callback + + , GLFW.MouseButton(..) + , GLFW.MouseButtonState(..) + , GLFW.ModifierKeys(..) + + , mkCallback + ) where + +import RIO + +import Graphics.UI.GLFW qualified as GLFW +import RIO.App (appEnv) +import UnliftIO.Resource (ReleaseKey) +import UnliftIO.Resource qualified as Resource + +import Engine.Types (GlobalHandles(..), StageRIO) + +type Callback st = Double -> Double -> StageRIO st () + +callback :: Callback st -> StageRIO st ReleaseKey +callback handler = do + window <- asks $ ghWindow . appEnv + withUnliftIO \ul -> + GLFW.setCursorPosCallback window . Just $ mkCallback ul handler + Resource.register $ + GLFW.setCursorPosCallback window Nothing + +mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.CursorPosCallback +mkCallback (UnliftIO ul) action = + \_window px py -> + ul $ action px py diff --git a/src/Engine/Window/Drop.hs b/src/Engine/Window/Drop.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Window/Drop.hs @@ -0,0 +1,30 @@ +module Engine.Window.Drop + ( Callback + , callback + + , mkCallback + ) where + +import RIO + +import Graphics.UI.GLFW qualified as GLFW +import RIO.App (appEnv) +import UnliftIO.Resource (ReleaseKey) +import UnliftIO.Resource qualified as Resource + +import Engine.Types (GlobalHandles(..), StageRIO) + +type Callback st = [FilePath] -> StageRIO st () + +callback :: Callback st -> StageRIO st ReleaseKey +callback handler = do + window <- asks $ ghWindow . appEnv + withUnliftIO \ul -> + GLFW.setDropCallback window . Just $ mkCallback ul handler + Resource.register $ + GLFW.setDropCallback window Nothing + +mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.DropCallback +mkCallback (UnliftIO ul) action = + \_window files -> + ul $ action files diff --git a/src/Engine/Window/Key.hs b/src/Engine/Window/Key.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Window/Key.hs @@ -0,0 +1,34 @@ +module Engine.Window.Key + ( Callback + , callback + + , GLFW.Key(..) + , GLFW.KeyState(..) + , GLFW.ModifierKeys(..) + + , mkCallback + ) where + +import RIO + +import Graphics.UI.GLFW qualified as GLFW +import RIO.App (appEnv) +import UnliftIO.Resource (ReleaseKey) +import UnliftIO.Resource qualified as Resource + +import Engine.Types (GlobalHandles(..), StageRIO) + +type Callback st = Int -> (GLFW.ModifierKeys, GLFW.KeyState, GLFW.Key) -> StageRIO st () + +callback :: Callback st -> StageRIO st ReleaseKey +callback handler = do + window <- asks $ ghWindow . appEnv + withUnliftIO \ul -> + GLFW.setKeyCallback window . Just $ mkCallback ul handler + Resource.register $ + GLFW.setKeyCallback window Nothing + +mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.KeyCallback +mkCallback (UnliftIO ul) action = + \_window key keyCode keyState mods -> + ul $ action keyCode (mods, keyState, key) diff --git a/src/Engine/Window/MouseButton.hs b/src/Engine/Window/MouseButton.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Window/MouseButton.hs @@ -0,0 +1,34 @@ +module Engine.Window.MouseButton + ( Callback + , callback + + , GLFW.MouseButton(..) + , GLFW.MouseButtonState(..) + , GLFW.ModifierKeys(..) + + , mkCallback + ) where + +import RIO + +import Graphics.UI.GLFW qualified as GLFW +import RIO.App (appEnv) +import UnliftIO.Resource (ReleaseKey) +import UnliftIO.Resource qualified as Resource + +import Engine.Types (GlobalHandles(..), StageRIO) + +type Callback st = (GLFW.ModifierKeys, GLFW.MouseButtonState, GLFW.MouseButton) -> StageRIO st () + +callback :: Callback st -> StageRIO st ReleaseKey +callback handler = do + window <- asks $ ghWindow . appEnv + withUnliftIO \ul -> + GLFW.setMouseButtonCallback window . Just $ mkCallback ul handler + Resource.register $ + GLFW.setMouseButtonCallback window Nothing + +mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.MouseButtonCallback +mkCallback (UnliftIO ul) action = + \_window button buttonState mods -> + ul $ action (mods, buttonState, button) diff --git a/src/Engine/Window/Scroll.hs b/src/Engine/Window/Scroll.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Window/Scroll.hs @@ -0,0 +1,30 @@ +module Engine.Window.Scroll + ( Callback + , callback + + , mkCallback + ) where + +import RIO + +import Graphics.UI.GLFW qualified as GLFW +import RIO.App (appEnv) +import UnliftIO.Resource (ReleaseKey) +import UnliftIO.Resource qualified as Resource + +import Engine.Types (GlobalHandles(..), StageRIO) + +type Callback st = Double -> Double -> StageRIO st () + +callback :: Callback st -> StageRIO st ReleaseKey +callback handler = do + window <- asks $ ghWindow . appEnv + withUnliftIO \ul -> + GLFW.setScrollCallback window . Just $ mkCallback ul handler + Resource.register $ + GLFW.setScrollCallback window Nothing + +mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.ScrollCallback +mkCallback (UnliftIO ul) action = + \_window dx dy -> + ul $ action dx dy diff --git a/src/Engine/Worker.hs b/src/Engine/Worker.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Worker.hs @@ -0,0 +1,672 @@ +module Engine.Worker + ( Versioned(..) + , Var + , newVar + , readVar + , stateVar + , stateVarMap + + , HasInput(..) + , pushInput + , pushInputSTM + , updateInput + , updateInputSTM + , getInputData + , getInputDataSTM + + , HasConfig(..) + , modifyConfig + , modifyConfigSTM + + , HasOutput(..) + , updateOutput + , updateOutputSTM + , getOutputData + , getOutputDataSTM + + , Cell(..) + , spawnCell + + , Timed(..) + , spawnTimed + , spawnTimed_ + + , Merge(..) + , spawnMerge1 + , spawnMerge2 + , spawnMerge3 + , spawnMerge4 + + , ObserverIO + , newObserverIO + , observeIO + , observeIO_ + , readObservedIO + + , Source + , newSource + , pubSource + , subSource + + , HasWorker(..) + , register + , registerCollection + , registered + , registeredCollection + ) where + +import RIO + +import Control.Concurrent.Chan.Unagi.Unboxed (UnagiPrim) +import Control.Concurrent.Chan.Unagi.Unboxed qualified as UnagiPrim +import Data.Vector.Unboxed qualified as Unboxed +import UnliftIO.Concurrent (forkIO, killThread) +import UnliftIO.Resource (MonadResource) +import UnliftIO.Resource qualified as Resource +import Data.StateVar qualified as StateVar + +data Versioned a = Versioned + { vVersion :: Unboxed.Vector Word64 + , vData :: a + } + deriving (Show, Functor, Foldable, Traversable) + +instance Eq (Versioned a) where + a == b = vVersion a == vVersion b + +instance Ord (Versioned a) where + compare a b = compare (vVersion a) (vVersion b) + +type Var a = TVar (Versioned a) + +newVar :: MonadUnliftIO m => a -> m (Var a) +newVar initial = newTVarIO Versioned + { vVersion = Unboxed.singleton 0 + , vData = initial + } + +stateVar :: HasInput var => var -> StateVar.StateVar (GetInput var) +stateVar var = StateVar.makeStateVar + (getInputData var) + (\new -> pushInput var \_old -> new) + +stateVarMap + :: HasInput var + => (GetInput var -> a) + -> (a -> GetInput var -> GetInput var) + -> var + -> StateVar.StateVar a +stateVarMap mapGet mapSet var = StateVar.makeStateVar + (fmap mapGet $ getInputData var) + (\new -> pushInput var (mapSet new)) + +{-# INLINEABLE readVar #-} +readVar :: (MonadUnliftIO m) => Var a -> m a +readVar = fmap vData . readTVarIO + +{-# INLINEABLE pushVarSTM #-} +pushVarSTM :: Var a -> (a -> a) -> STM () +pushVarSTM var f = + modifyTVar' var \Versioned{vVersion, vData} -> + Versioned + { vVersion = Unboxed.map (+ 1) vVersion + , vData = f vData + } + +{-# INLINEABLE updateVarSTM #-} +updateVarSTM :: Var a -> (a -> Maybe a) -> STM () +updateVarSTM var f = do + current <- readTVar var + let + oldData = vData current + case f oldData of + Nothing -> + pure () + Just newData -> + writeTVar var Versioned + { vVersion = Unboxed.map (+1) (vVersion current) + , vData = newData + } + +class HasInput a where + type GetInput a + getInput :: a -> Var (GetInput a) + +instance HasInput (TVar (Versioned a)) where + type GetInput (TVar (Versioned a)) = a + getInput = id + +{-# INLINEABLE pushInput #-} +pushInput + :: (MonadIO m, HasInput var) + => var + -> (GetInput var -> GetInput var) + -> m () +pushInput input = + atomically . pushInputSTM input + +{-# INLINEABLE pushInputSTM #-} +pushInputSTM + :: HasInput var + => var + -> (GetInput var -> GetInput var) + -> STM () +pushInputSTM input = pushVarSTM (getInput input) + +{-# INLINEABLE updateInput #-} +updateInput + :: ( MonadIO m + , HasInput var + ) + => var + -> (GetInput var -> Maybe (GetInput var)) + -> m () +updateInput input = + atomically . updateInputSTM input + +updateInputSTM + :: HasInput var + => var + -> (GetInput var -> Maybe (GetInput var)) + -> STM () +updateInputSTM input = updateVarSTM (getInput input) + +{-# INLINEABLE getInputData #-} +getInputData :: (HasInput worker, MonadIO m) => worker -> m (GetInput worker) +getInputData = fmap vData . readTVarIO . getInput + +{-# INLINEABLE getInputDataSTM #-} +getInputDataSTM :: (HasInput worker) => worker -> STM (GetInput worker) +getInputDataSTM = fmap vData . readTVar . getInput + +class HasConfig a where + type GetConfig a + getConfig :: a -> TVar (GetConfig a) + +instance HasConfig (TVar a) where + type GetConfig (TVar a) = a + getConfig = id + +modifyConfig + :: (MonadIO m, HasConfig var) + => var + -> (GetConfig var -> GetConfig var) + -> m () +modifyConfig config = + atomically . modifyConfigSTM config + +modifyConfigSTM + :: HasConfig var + => var + -> (GetConfig var -> GetConfig var) + -> STM () +modifyConfigSTM config = + modifyTVar' (getConfig config) + +class HasOutput a where + type GetOutput a + getOutput :: a -> Var (GetOutput a) + +instance HasOutput (TVar (Versioned a)) where + type GetOutput (TVar (Versioned a)) = a + getOutput = id + +{-# INLINEABLE pushOutput #-} +pushOutput + :: (MonadIO m, HasOutput var) + => var + -> (GetOutput var -> GetOutput var) + -> m () +pushOutput output = + atomically . pushOutputSTM output + +pushOutputSTM + :: HasOutput var + => var + -> (GetOutput var -> GetOutput var) + -> STM () +pushOutputSTM output f = + modifyTVar' (getOutput output) \Versioned{vVersion, vData} -> + Versioned + { vVersion = Unboxed.map (+1) vVersion + , vData = f vData + } + +{-# INLINEABLE updateOutput #-} +updateOutput + :: (MonadIO m, HasOutput var) + => var + -> (GetOutput var -> Maybe (GetOutput var)) + -> m () +updateOutput output = + atomically . updateOutputSTM output + +updateOutputSTM + :: HasOutput var + => var + -> (GetOutput var -> Maybe (GetOutput var)) + -> STM () +updateOutputSTM output f = do + current <- readTVar outputVar + let + oldData = vData current + case f oldData of + Nothing -> + pure () + Just newData -> + writeTVar outputVar Versioned + { vVersion = Unboxed.map (+1) (vVersion current) + , vData = newData + } + where + outputVar = getOutput output + +{-# INLINEABLE getOutputData #-} +getOutputData :: (HasOutput worker, MonadIO m) => worker -> m (GetOutput worker) +getOutputData = fmap vData . readTVarIO . getOutput + +{-# INLINEABLE getOutputDataSTM #-} +getOutputDataSTM :: (HasOutput worker) => worker -> STM (GetOutput worker) +getOutputDataSTM = fmap vData . readTVar . getOutput + +-- * Suppply + +-- | Updatable cell for composite input or costly output. +data Cell input output = Cell + { cWorker :: ThreadId + , cInput :: Var input + , cOutput :: Var output + } + +instance HasInput (Cell i o) where + type GetInput (Cell i o) = i + getInput = cInput + +instance HasOutput (Cell i o) where + type GetOutput (Cell i o) = o + getOutput = cOutput + +spawnCell + :: MonadUnliftIO m + => (input -> output) + -> input + -> m (Cell input output) +spawnCell f initial = do + input <- newVar initial + + output <- newVar (f initial) + + worker <- forkIO $ + forever $ atomically do + next <- readTVar input + old <- readTVar output + + if Unboxed.head (vVersion next) > Unboxed.head (vVersion old) then + writeTVar output Versioned + { vVersion = vVersion next + , vData = f (vData next) + } + else + retrySTM + + pure Cell + { cWorker = worker + , cInput = input + , cOutput = output + } + +-- | Timer-driven stateful producer. +data Timed config output = Timed + { tWorker :: ThreadId + , tActive :: TVar Bool + , tConfig :: TVar config + , tOutput :: Var output + } + +instance HasConfig (Timed config output) where + type GetConfig (Timed config output) = config + getConfig = tConfig + +instance HasOutput (Timed config output) where + type GetOutput (Timed config output) = output + getOutput = tOutput + +spawnTimed_ + :: MonadUnliftIO m + => Int + -> Bool + -> m output + -> m (Timed () output) +spawnTimed_ dt startActive stepF = + spawnTimed + (\_old () -> fmap (,()) stepF) + (Left dt) + startActive + (error "assert: spawnTimed_ ignores old") + () + +spawnTimed + :: MonadUnliftIO m + => (state -> config -> m (output, state)) + -> Either Int (config -> Int) + -> Bool + -> state + -> config + -> m (Timed config output) +spawnTimed stepF dtF startActive initialState initialConfig = do + tActive <- newTVarIO startActive + tConfig <- newTVarIO initialConfig + (initialOutput, nextState) <- stepF initialState initialConfig + tOutput <- newVar initialOutput + tWorker <- forkIO $ step tActive tConfig tOutput nextState + pure Timed{..} + where + step activeVar configVar output curState = do + case dtF of + Left static -> + threadDelay static + Right fromConfig -> + readTVarIO configVar >>= + threadDelay . fromConfig + + active <- readTVarIO activeVar + if active then do + config <- readTVarIO configVar + (nextOutput, nextState) <- stepF curState config + pushOutput output $ const nextOutput + step activeVar configVar output nextState + else + step activeVar configVar output curState + +-- | Supply-driven step cell. +data Merge o = Merge + { mWorker :: ThreadId + , mOutput :: TVar (Versioned o) + } + +instance HasOutput (Merge o) where + type GetOutput (Merge o) = o + getOutput = mOutput + +spawnMerge1 + :: ( MonadUnliftIO m + , HasOutput i + ) + => (GetOutput i -> o) + -> i + -> m (Merge o) +spawnMerge1 f i = do + output <- atomically do + initial <- readTVar (getOutput i) + newTVar Versioned + { vVersion = vVersion initial + , vData = f (vData initial) + } + + worker <- forkIO $ + forever $ atomically do + next <- readTVar (getOutput i) + old <- readTVar output + + let nextVersion = vVersion next + if nextVersion > vVersion old then + writeTVar output Versioned + { vVersion = nextVersion + , vData = f (vData next) + } + else + retrySTM + + pure Merge + { mWorker = worker + , mOutput = output + } + +spawnMerge2 + :: ( MonadUnliftIO m + , HasOutput i1 + , HasOutput i2 + ) + => (GetOutput i1 -> GetOutput i2 -> o) + -> i1 + -> i2 + -> m (Merge o) +spawnMerge2 f i1 i2 = do + output <- atomically do + (initial1, initial2) <- (,) + <$> readTVar (getOutput i1) + <*> readTVar (getOutput i2) + + newTVar Versioned + { vVersion = mkVersion initial1 initial2 + , vData = f (vData initial1) (vData initial2) + } + + worker <- forkIO $ + forever $ atomically $ do + next1 <- readTVar (getOutput i1) + next2 <- readTVar (getOutput i2) + old <- readTVar output + + let nextVersion = mkVersion next1 next2 + + if nextVersion > vVersion old then + writeTVar output Versioned + { vVersion = nextVersion + , vData = f (vData next1) (vData next2) + } + else + retrySTM + + pure Merge + { mWorker = worker + , mOutput = output + } + where + mkVersion a b = vVersion a <> vVersion b + +spawnMerge3 + :: ( MonadUnliftIO m + , HasOutput i1 + , HasOutput i2 + , HasOutput i3 + ) + => (GetOutput i1 -> GetOutput i2 -> GetOutput i3 -> o) + -> i1 + -> i2 + -> i3 + -> m (Merge o) +spawnMerge3 f i1 i2 i3 = do + output <- atomically do + (initial1, initial2, initial3) <- (,,) + <$> readTVar (getOutput i1) + <*> readTVar (getOutput i2) + <*> readTVar (getOutput i3) + + newTVar Versioned + { vVersion = mkVersion initial1 initial2 initial3 + , vData = f (vData initial1) (vData initial2) (vData initial3) + } + + worker <- forkIO $ + forever $ atomically $ do + next1 <- readTVar (getOutput i1) + next2 <- readTVar (getOutput i2) + next3 <- readTVar (getOutput i3) + old <- readTVar output + + let nextVersion = mkVersion next1 next2 next3 + + if nextVersion > vVersion old then + writeTVar output Versioned + { vVersion = nextVersion + , vData = f (vData next1) (vData next2) (vData next3) + } + else + retrySTM + + pure Merge + { mWorker = worker + , mOutput = output + } + where + mkVersion a b c = mconcat [vVersion a, vVersion b, vVersion c] + +spawnMerge4 + :: ( MonadUnliftIO m + , HasOutput i1 + , HasOutput i2 + , HasOutput i3 + , HasOutput i4 + ) + => (GetOutput i1 -> GetOutput i2 -> GetOutput i3 -> GetOutput i4 -> o) + -> i1 + -> i2 + -> i3 + -> i4 + -> m (Merge o) +spawnMerge4 f i1 i2 i3 i4 = do + output <- atomically do + (initial1, initial2, initial3, initial4) <- (,,,) + <$> readTVar (getOutput i1) + <*> readTVar (getOutput i2) + <*> readTVar (getOutput i3) + <*> readTVar (getOutput i4) + + newTVar Versioned + { vVersion = mkVersion initial1 initial2 initial3 initial4 + , vData = f (vData initial1) (vData initial2) (vData initial3) (vData initial4) + } + + worker <- forkIO $ + forever $ atomically $ do + next1 <- readTVar (getOutput i1) + next2 <- readTVar (getOutput i2) + next3 <- readTVar (getOutput i3) + next4 <- readTVar (getOutput i4) + old <- readTVar output + + let nextVersion = mkVersion next1 next2 next3 next4 + + if nextVersion > vVersion old then + writeTVar output Versioned + { vVersion = nextVersion + , vData = f (vData next1) (vData next2) (vData next3) (vData next4) + } + else + retrySTM + + pure Merge + { mWorker = worker + , mOutput = output + } + where + mkVersion a b c d = mconcat [vVersion a, vVersion b, vVersion c, vVersion d] + +-- * Demand + +type ObserverIO a = IORef (Versioned a) + +newObserverIO :: MonadIO m => a -> m (ObserverIO a) +newObserverIO initial = newIORef Versioned + { vVersion = mempty + , vData = initial + } + +observeIO + :: (MonadUnliftIO m, HasOutput output) + => output + -> ObserverIO a + -> (a -> GetOutput output -> m a) + -> m a +observeIO output currentRef action = do + outputV <- readTVarIO (getOutput output) + currentV <- readIORef currentRef + if vVersion outputV > vVersion currentV then do + derived <- action (vData currentV) (vData outputV) + atomicWriteIORef currentRef Versioned + { vVersion = vVersion outputV + , vData = derived + } + pure derived + else + pure (vData currentV) + +observeIO_ + :: (MonadUnliftIO m, HasOutput output) + => output + -> ObserverIO a + -> (a -> GetOutput output -> m a) + -> m () +observeIO_ output currentRef = + void . observeIO output currentRef + +{-# INLINEABLE readObservedIO #-} +readObservedIO :: (MonadUnliftIO m) => IORef (Versioned a) -> m a +readObservedIO = fmap vData . readIORef + +-- * PubSub + +newtype Source a = Source (UnagiPrim.InChan a) + +newSource :: (MonadUnliftIO m, UnagiPrim a) => m (Source a) +newSource = fmap (Source . fst) $ liftIO UnagiPrim.newChan + +pubSource :: (MonadUnliftIO m, UnagiPrim a) => Source a -> a -> m () +pubSource (Source ic) = liftIO . UnagiPrim.writeChan ic + +subSource :: MonadUnliftIO m => Source a -> m (UnagiPrim.OutChan a) +subSource (Source ic) = liftIO $ UnagiPrim.dupChan ic + +-- * Utils + +class HasWorker a where + getWorker :: a -> ThreadId + +instance HasWorker (Cell i o) where + getWorker = cWorker + +instance HasWorker (Timed c o) where + getWorker = tWorker + +instance HasWorker (Merge o) where + getWorker = mWorker + +register + :: ( MonadResource m + , HasWorker process + ) + => process + -> m Resource.ReleaseKey +register = Resource.register . killThread . getWorker + +registerCollection + :: ( MonadResource m + , HasWorker process + , Foldable t + ) + => t process + -> m Resource.ReleaseKey +registerCollection = Resource.register . traverse_ (killThread . getWorker) + +registered :: (MonadResource m, HasWorker a) => m a -> m (Resource.ReleaseKey, a) +registered spawn = do + worker <- spawn + key <- Resource.register $ killThread (getWorker worker) + pure (key, worker) + +registeredCollection + :: ( MonadResource m + , HasWorker process + , Traversable t + ) + => (input -> m process) + -> t input + -> m (Resource.ReleaseKey, t process) +registeredCollection spawn inputs = do + workers <- traverse spawn inputs + + key <- Resource.register $ + traverse_ (killThread . getWorker) workers + + pure (key, workers) diff --git a/src/Render/Code.hs b/src/Render/Code.hs new file mode 100644 --- /dev/null +++ b/src/Render/Code.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -fno-prof-auto #-} + +module Render.Code + ( compileVert + , compileFrag + , glsl + , trimming + , Code(..) + ) where + +import RIO + +import Language.Haskell.TH (Exp, Q) +import NeatInterpolation (trimming) +import RIO.Text qualified as Text +import Vulkan.Utils.ShaderQQ.GLSL.Glslang (compileShaderQ, glsl) + +compileVert :: String -> Q Exp +compileVert = compileShaderQ Nothing "vert" Nothing + +compileFrag :: String -> Q Exp +compileFrag = compileShaderQ Nothing "frag" Nothing + +-- | A wrapper to `show` code into `compileShaderQ` vars. +newtype Code = Code { unCode :: Text } + deriving (Eq, Ord) + +instance Show Code where + show = Text.unpack . unCode diff --git a/src/Render/Code/Noise.hs b/src/Render/Code/Noise.hs new file mode 100644 --- /dev/null +++ b/src/Render/Code/Noise.hs @@ -0,0 +1,15 @@ +module Render.Code.Noise + ( hash33 + ) where + +import Render.Code (Code(..), trimming) + +hash33 :: Code +hash33 = Code + [trimming| + vec3 hash33(vec3 a) { + vec3 p = fract(a * vec3(443.8975, 397.2973, 491.1871)); + p += dot(p.zxy, p.yxz + 19.27); + return fract(vec3(p.x * p.y, p.z * p.x, p.y * p.z)); + } + |] diff --git a/src/Render/Draw.hs b/src/Render/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Render/Draw.hs @@ -0,0 +1,231 @@ +module Render.Draw + ( triangle_ + , triangles_ + , quads + + , indexed + , indexedRanges + , indexedParts + + , indexedPos + , indexedPosRanges + + , unsafeIndexedRanges + , unsafeIndexedParts + ) where + +import RIO + +import Data.Vector qualified as Vector +import Vulkan.Core10 qualified as Vk + +import Engine.Vulkan.Types (Bound(..)) +import Resource.Buffer qualified as Buffer +import Resource.Model qualified as Model + +-- * Primitives + +-- | Single triangle, binding nothing. +triangle_ :: MonadUnliftIO m => Vk.CommandBuffer -> Bound dsl () () m () +triangle_ cb = triangles_ cb 1 + +-- | Multiple shader-driven triangles without bindings. +triangles_ :: MonadUnliftIO m => Vk.CommandBuffer -> Word32 -> Bound dsl () () m () +triangles_ cb num = + Bound $ Vk.cmdDraw cb 3 num 0 0 + +-- | Instanced quads. +quads + :: MonadUnliftIO m + => Vk.CommandBuffer + -> Buffer.Allocated stage instances + -> Bound dsl () instances m () +quads cb instances = Bound do + Vk.cmdBindVertexBuffers cb 0 (pure $ Buffer.aBuffer instances) (pure 0) + Vk.cmdDraw cb 6 (Buffer.aUsed instances) 0 0 + +-- * Indexed models + +-- ** Positions + attributes + +-- | Draw whole-model instances. +indexed + :: (MonadUnliftIO m, Model.HasVertexBuffers instances) + => Vk.CommandBuffer + -> Model.Indexed storage pos attrs + -> instances + -> Bound dsl attrs (Model.VertexBuffersOf instances) m () +indexed cmd model instances = indexedRanges cmd model instances [wholeIndexed] + where + wholeIndexed = Model.IndexRange + { irFirstIndex = 0 + , irIndexCount = Buffer.aUsed (Model.iIndices model) + } + +{- | + Draw subrange of each instance. + + E.g. chunks of the same material drawn in different places. +-} +indexedRanges + :: (MonadUnliftIO m, Model.HasVertexBuffers instances) + => Vk.CommandBuffer + -> Model.Indexed storage pos attrs + -> instances + -> [Model.IndexRange] + -> Bound dsl attrs (Model.VertexBuffersOf instances) m () +indexedRanges cmd model instances ranges = do + checkedTanges <- traverse check ranges + Bound $ unsafeIndexedRanges True cmd model instances checkedTanges + where + check ir@Model.IndexRange{..} + | irFirstIndex > maxIndex = + throwString "firstIndex is over the actual buffer size" + | irFirstIndex + irIndexCount > maxIndex = + throwString "firstIndex + indexCount is over the actual buffer size" + | otherwise = + pure ir + + maxIndex = Buffer.aUsed (Model.iIndices model) + +{- | + Draw ranges and instances zipped. + + E.g. range materials stored in instances. +-} +indexedParts + :: (MonadUnliftIO m, Model.HasVertexBuffers instances, Foldable t) + => Bool + -> Vk.CommandBuffer + -> Model.Indexed storage pos attrs + -> instances + -> Int + -> t Model.IndexRange + -> Bound dsl attrs (Model.VertexBuffersOf instances) m () +indexedParts drawAttrs cmd model instances startInstance parts = + Bound $ unsafeIndexedParts drawAttrs cmd model instances startInstance parts + +-- ** Position-only draws + +-- | Draw whole-model instances, ignoring attributes. +indexedPos + :: (MonadUnliftIO m, Model.HasVertexBuffers instances) + => Vk.CommandBuffer + -> Model.Indexed storage pos unusedAttrs + -> instances + -> Bound dsl ignoreAttrs (Model.VertexBuffersOf instances) m () +indexedPos cmd model instances = indexedPosRanges cmd model instances [wholeIndexed] + where + wholeIndexed = Model.IndexRange + { irFirstIndex = 0 + , irIndexCount = Buffer.aUsed (Model.iIndices model) + } + +-- | Draw subrange of each instances, ignoring attributes. +indexedPosRanges + :: (MonadUnliftIO m, Model.HasVertexBuffers instances) + => Vk.CommandBuffer + -> Model.Indexed storage pos unusedAttrs + -> instances + -> [Model.IndexRange] + -> Bound dsl ignoreAttrs (Model.VertexBuffersOf instances) m () +indexedPosRanges cmd model instances ranges = do + checkedTanges <- traverse check ranges + Bound $ unsafeIndexedRanges False cmd model instances checkedTanges + where + check ir@Model.IndexRange{..} + | irFirstIndex > maxIndex = + throwString "firstIndex is over the actual buffer size" + | irFirstIndex + irIndexCount > maxIndex = + throwString "firstIndex + indexCount is over the actual buffer size" + | otherwise = + pure ir + + maxIndex = Buffer.aUsed (Model.iIndices model) + +-- * Unchecked implementations + +-- | Common unchecked part for pos/attrs +unsafeIndexedRanges + :: (MonadUnliftIO io, Model.HasVertexBuffers instances, Foldable t) + => Bool + -> Vk.CommandBuffer + -> Model.Indexed storage pos attrs + -> instances + -> t Model.IndexRange + -> io () +unsafeIndexedRanges drawAttrs cmd Model.Indexed{..} instances indexRanges = + case toList indexRanges of + [] -> + pure () + + _skip | instanceCount < 1 -> + pure () + + someRanges -> liftIO do + Vk.cmdBindVertexBuffers cmd 0 vertexBuffers bufferOffsets + Vk.cmdBindIndexBuffer cmd (Buffer.aBuffer iIndices) indexBufferOffset Vk.INDEX_TYPE_UINT32 + for_ someRanges \Model.IndexRange{..} -> + Vk.cmdDrawIndexed cmd irIndexCount instanceCount irFirstIndex vertexOffset firstInstance + + where + indexBufferOffset = 0 + vertexOffset = 0 + + instanceCount = Model.getInstanceCount instances + firstInstance = 0 + + vertexBuffers = Vector.fromList $ + if drawAttrs then + Buffer.aBuffer iPositions : + Buffer.aBuffer iAttrs : + Model.getVertexBuffers instances + else + Buffer.aBuffer iPositions : + Model.getVertexBuffers instances + + bufferOffsets = + Vector.replicate (Vector.length vertexBuffers) 0 + +-- | Instance/range zipped +unsafeIndexedParts + :: (MonadUnliftIO io, Model.HasVertexBuffers instances, Foldable t) + => Bool + -> Vk.CommandBuffer + -> Model.Indexed storage pos attrs + -> instances + -> Int + -> t Model.IndexRange + -> io () +unsafeIndexedParts drawAttrs cmd Model.Indexed{..} instances startInstance parts = + case drop startInstance (toList parts) of + [] -> + pure () + + _skip | instanceCount < 1 -> + pure () + + someRanges -> liftIO do + Vk.cmdBindVertexBuffers cmd 0 vertexBuffers bufferOffsets + Vk.cmdBindIndexBuffer cmd (Buffer.aBuffer iIndices) indexBufferOffset Vk.INDEX_TYPE_UINT32 + for_ (zip [fromIntegral startInstance ..] someRanges) \(firstInstance, Model.IndexRange{..}) -> + Vk.cmdDrawIndexed cmd irIndexCount instanceCount irFirstIndex vertexOffset firstInstance + + where + indexBufferOffset = 0 + vertexOffset = 0 + + instanceCount = 1 -- Model.getInstanceCount instances + -- firstInstance = 0 + + vertexBuffers = Vector.fromList $ + if drawAttrs then + Buffer.aBuffer iPositions : + Buffer.aBuffer iAttrs : + Model.getVertexBuffers instances + else + Buffer.aBuffer iPositions : + Model.getVertexBuffers instances + + bufferOffsets = + Vector.replicate (Vector.length vertexBuffers) 0 diff --git a/src/Render/Samplers.hs b/src/Render/Samplers.hs new file mode 100644 --- /dev/null +++ b/src/Render/Samplers.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Render.Samplers + ( Collection(..) + , allocate + , indices + + , Params + , create + , destroy + ) where + +import RIO + +import Control.Monad.Trans.Resource qualified as Resource +import Data.Distributive (Distributive(..)) +import Data.Distributive.Generic (genericCollect) +import Data.Functor.Rep (Co(..), Representable) +import GHC.Generics (Generic1) +import Vulkan.Core10 qualified as Vk +import Vulkan.NamedType ((:::)) +import Vulkan.Zero (zero) + +import Engine.Vulkan.Types (HasSwapchain(..), HasVulkan(..), MonadVulkan) +import Resource.Collection qualified as Collection + +data Collection a = Collection + { linearMipRepeat :: a + , linearMip :: a + , linearRepeat :: a + , linear :: a + , nearestMipRepeat :: a + , nearestMip :: a + , nearestRepeat :: a + , nearest :: a + } + deriving stock (Show, Functor, Foldable, Traversable, Generic, Generic1) + deriving Applicative via (Co Collection) + deriving anyclass (Representable) + +instance Distributive Collection where + collect = genericCollect + +type Params = (Vk.Filter, "LOD clamp" ::: Float, Vk.SamplerAddressMode) + +params :: Collection Params +params = Collection + { linearMipRepeat = (Vk.FILTER_LINEAR, Vk.LOD_CLAMP_NONE, Vk.SAMPLER_ADDRESS_MODE_REPEAT) -- 0 + , linearMip = (Vk.FILTER_LINEAR, Vk.LOD_CLAMP_NONE, Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_BORDER) -- 1 + , linearRepeat = (Vk.FILTER_LINEAR, 0, Vk.SAMPLER_ADDRESS_MODE_REPEAT) -- 2 + , linear = (Vk.FILTER_LINEAR, 0, Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_BORDER) -- 3 + , nearestMipRepeat = (Vk.FILTER_NEAREST, Vk.LOD_CLAMP_NONE, Vk.SAMPLER_ADDRESS_MODE_REPEAT) -- 4 + , nearestMip = (Vk.FILTER_NEAREST, Vk.LOD_CLAMP_NONE, Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_BORDER) -- 5 + , nearestRepeat = (Vk.FILTER_NEAREST, 0, Vk.SAMPLER_ADDRESS_MODE_REPEAT) -- 6 + , nearest = (Vk.FILTER_NEAREST, 0, Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_BORDER) -- 7 + } + +indices :: Collection Int32 +indices = fmap fst $ Collection.enumerate params + +allocate + :: ( MonadVulkan env m + , Resource.MonadResource m + , HasSwapchain a + ) + => a + -> m (Resource.ReleaseKey, Collection Vk.Sampler) +allocate swapchain = do + context <- ask + Resource.allocate + (for params $ create context $ getAnisotropy swapchain) + (traverse_ $ destroy context) + +create + :: (MonadIO io, HasVulkan context) + => context + -> "max anisotropy" ::: Float + -> Params + -> io Vk.Sampler +create context maxAnisotropy (filt, mips, reps) = + Vk.createSampler (getDevice context) samplerCI Nothing + where + samplerCI = zero + { Vk.magFilter = filt + , Vk.minFilter = filt + , Vk.addressModeU = reps + , Vk.addressModeV = reps + , Vk.addressModeW = reps + , Vk.anisotropyEnable = maxAnisotropy > 1 + , Vk.maxAnisotropy = maxAnisotropy + , Vk.borderColor = Vk.BORDER_COLOR_INT_OPAQUE_BLACK + , Vk.unnormalizedCoordinates = False + , Vk.compareEnable = False + , Vk.compareOp = Vk.COMPARE_OP_ALWAYS + , Vk.mipmapMode = Vk.SAMPLER_MIPMAP_MODE_LINEAR + , Vk.mipLodBias = 0 + , Vk.minLod = 0 + , Vk.maxLod = mips + } + +destroy :: (MonadIO io, HasVulkan context) => context -> Vk.Sampler -> io () +destroy context sampler = + Vk.destroySampler (getDevice context) sampler Nothing diff --git a/src/Resource/Buffer.hs b/src/Resource/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Buffer.hs @@ -0,0 +1,217 @@ +module Resource.Buffer where + +import RIO + +import Data.Bits ((.|.)) +import Data.Vector.Storable qualified as VectorS +import Foreign (Storable) +import Foreign qualified +import UnliftIO.Resource qualified as Resource +import Vulkan.Core10 qualified as Vk +import Vulkan.NamedType ((:::)) +import Vulkan.Zero (zero) +import VulkanMemoryAllocator qualified as VMA + +import Engine.Vulkan.Types (HasVulkan(getAllocator), Queues(qTransfer)) +import Resource.CommandBuffer (oneshot_) + +data Store = Staged | Coherent + +data Allocated (s :: Store) a = Allocated + { aBuffer :: Vk.Buffer + , aAllocation :: VMA.Allocation + , aAllocationInfo :: VMA.AllocationInfo + , aCapacity :: Int + , aUsed :: Word32 + , aUsage :: Vk.BufferUsageFlagBits + } deriving (Show) + +allocateCoherent + :: (Resource.MonadResource m, Storable a, HasVulkan context) + => context + -> Vk.BufferUsageFlagBits + -> "initial size" ::: Int + -> VectorS.Vector a + -> m (Resource.ReleaseKey, Allocated 'Coherent a) +allocateCoherent context usage initialSize xs = + Resource.allocate + (createCoherent context usage initialSize xs) + (destroy context) + +createCoherent + :: forall a context io . (Storable a, HasVulkan context, MonadUnliftIO io) + => context + -> Vk.BufferUsageFlagBits + -> "initial size" ::: Int + -> VectorS.Vector a + -> io (Allocated 'Coherent a) +createCoherent context usage initialSize xs = do + (aBuffer, aAllocation, aAllocationInfo) <- VMA.createBuffer (getAllocator context) bci aci + + when (len /= 0) $ + if VMA.mappedData aAllocationInfo == Foreign.nullPtr then + error "TODO: recover from unmapped data and flush manually" + else + liftIO $ VectorS.unsafeWith xs \src -> + Foreign.copyBytes (Foreign.castPtr $ VMA.mappedData aAllocationInfo) src lenBytes + + pure Allocated + { aCapacity = max initialSize len + , aUsed = fromIntegral len + , aUsage = usage + , .. + } + where + + len = VectorS.length xs + lenBytes = Foreign.sizeOf (undefined :: a) * len + + sizeBytes = Foreign.sizeOf (undefined :: a) * max initialSize len + + bci = zero + { Vk.size = fromIntegral sizeBytes + , Vk.usage = usage + , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE + } + + flags = + Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT .|. + Vk.MEMORY_PROPERTY_HOST_COHERENT_BIT + + aci = zero + { VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT + , VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY + , VMA.requiredFlags = flags + , VMA.preferredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT + } + +createStaged + :: forall a context io . (Storable a, HasVulkan context, MonadUnliftIO io) + => context + -> Queues Vk.CommandPool + -> Vk.BufferUsageFlagBits + -> Int + -> VectorS.Vector a + -> io (Allocated 'Staged a) +createStaged context commandQueues usage initialSize xs = do + (aBuffer, aAllocation, aAllocationInfo) <- VMA.createBuffer vma bci aci + + when (len /= 0) . liftIO $ + VMA.withBuffer vma stageCI stageAI bracket \(staging, _stage, stageInfo) -> + if VMA.mappedData stageInfo == Foreign.nullPtr then + error "TODO: recover from unmapped data and flush manually" + else do + VectorS.unsafeWith xs \src -> + Foreign.copyBytes (Foreign.castPtr $ VMA.mappedData stageInfo) src lenBytes + copyBuffer_ context commandQueues aBuffer staging (fromIntegral sizeBytes) + + pure Allocated + { aCapacity = max initialSize len + , aUsed = fromIntegral len + , aUsage = usage + , .. + } + where + vma = getAllocator context + + len = VectorS.length xs + lenBytes = Foreign.sizeOf (undefined :: a) * len + + sizeBytes = Foreign.sizeOf (undefined :: a) * max initialSize len + + bci = zero + { Vk.size = fromIntegral sizeBytes + , Vk.usage = Vk.BUFFER_USAGE_TRANSFER_DST_BIT .|. usage + , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE + } + + aci = zero + { VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY + , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT + } + + stageCI = zero + { Vk.size = fromIntegral sizeBytes + , Vk.usage = Vk.BUFFER_USAGE_TRANSFER_SRC_BIT + , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE + } + + stageAI = zero + { VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT + , VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU + , VMA.requiredFlags = Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT + } + +destroy + :: (MonadUnliftIO io, HasVulkan context) + => context + -> Allocated s a + -> io () +destroy context a = + VMA.destroyBuffer (getAllocator context) (aBuffer a) (aAllocation a) + +destroyAll + :: (MonadUnliftIO io, HasVulkan context, Foldable t) + => context + -> t (Allocated s a) + -> io () +destroyAll context = + traverse_ \a -> + VMA.destroyBuffer (getAllocator context) (aBuffer a) (aAllocation a) + +peekCoherent :: (MonadIO m, Storable a) => Word32 -> Allocated 'Coherent a -> m (Maybe a) +peekCoherent ix Allocated{..} = + case VMA.mappedData aAllocationInfo of + _ | ix + 1 > aUsed -> + pure Nothing + ptr | ptr == Foreign.nullPtr -> + pure Nothing + ptr -> + liftIO . fmap Just $ + Foreign.peekElemOff (Foreign.castPtr ptr) (fromIntegral ix) + +updateCoherent + :: (Foreign.Storable a, MonadUnliftIO io) + => VectorS.Vector a + -> Allocated 'Coherent a + -> io (Allocated 'Coherent a) +updateCoherent xs old = do + liftIO $ VectorS.unsafeWith xs \src -> + Foreign.copyBytes dst src lenBytes + pure old + { aUsed = fromIntegral len + } + where + dst = Foreign.castPtr $ VMA.mappedData (aAllocationInfo old) + len = VectorS.length xs + lenBytes = len * Foreign.sizeOf (VectorS.head xs) + +updateCoherentResize_ + :: (Storable a, HasVulkan context, MonadUnliftIO io) + => context + -> Allocated 'Coherent a + -> VectorS.Vector a + -> io (Allocated 'Coherent a) +updateCoherentResize_ ctx old xs = + if newSize <= oldSize then + updateCoherent xs old + else do + destroyAll ctx [old] + createCoherent ctx (aUsage old) newSize xs + where + oldSize = aCapacity old + newSize = VectorS.length xs + +-- TODO: add a staged buffer to check out the transfer queue +copyBuffer_ + :: (MonadUnliftIO io, HasVulkan context) + => context + -> Queues Vk.CommandPool + -> ("dstBuffer" ::: Vk.Buffer) + -> ("srcBuffer" ::: Vk.Buffer) + -> Vk.DeviceSize + -> io () +copyBuffer_ context commandQueues dst src sizeBytes = + oneshot_ context commandQueues qTransfer \cmd -> + Vk.cmdCopyBuffer cmd src dst + (pure $ Vk.BufferCopy 0 0 sizeBytes) diff --git a/src/Resource/Collection.hs b/src/Resource/Collection.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Collection.hs @@ -0,0 +1,33 @@ +module Resource.Collection + ( enumerate + , size + , toVector + , toVectorStorable + ) where + +import RIO + +import RIO.Vector qualified as Vector +import RIO.Vector.Storable qualified as VectorStorable +import Data.List qualified as List +import Data.Traversable (mapAccumL) + +{-# INLINE size #-} +size :: (Foldable t, Num size) => t a -> size +size = List.genericLength . toList + +enumerate :: (Traversable t, Num ix) => t a -> t (ix, a) +enumerate = snd . mapAccumL f 0 + where + f a b = (a + 1, (a, b)) + +{-# INLINE toVector #-} +toVector :: Foldable collection => collection a -> Vector a +toVector = Vector.fromList . toList + +{-# INLINE toVectorStorable #-} +toVectorStorable + :: (Foldable collection, Storable a) + => collection a + -> VectorStorable.Vector a +toVectorStorable = VectorStorable.fromList . toList diff --git a/src/Resource/Combined/Textures.hs b/src/Resource/Combined/Textures.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Combined/Textures.hs @@ -0,0 +1,51 @@ +module Resource.Combined.Textures + ( Collection(..) + , attachDebugNames + ) where + +import RIO + +import GHC.Stack (withFrozenCallStack) + +import Engine.Vulkan.Types (MonadVulkan) +import Resource.Texture (Texture, debugNameCollection) + +data Collection textures fonts a = Collection + -- XXX: textures go first, as there should be a filler texture at [0] + { textures :: textures a + , fonts :: fonts a + } + deriving (Show, Functor, Foldable, Traversable, Generic) + +instance + ( Applicative t + , Applicative f + ) + => Applicative (Collection t f) where + pure x = Collection + { textures = pure x + , fonts = pure x + } + + af <*> ax = Collection + { textures = textures af <*> textures ax + , fonts = fonts af <*> fonts ax + } + +attachDebugNames + :: ( Traversable textures + , Traversable fonts + , MonadVulkan env m + , HasLogFunc env + , HasCallStack + ) + => Collection textures fonts (Texture a) + -> textures FilePath + -> fonts FilePath + -> m () +attachDebugNames combined texturePaths fontPaths = + withFrozenCallStack $ + debugNameCollection combined Collection + { textures = texturePaths + , fonts = fontPaths + } diff --git a/src/Resource/CommandBuffer.hs b/src/Resource/CommandBuffer.hs new file mode 100644 --- /dev/null +++ b/src/Resource/CommandBuffer.hs @@ -0,0 +1,89 @@ +module Resource.CommandBuffer + ( allocatePools + , withPools + , oneshot_ + ) where + +import RIO + +import Data.Vector qualified as Vector +import UnliftIO.Resource (MonadResource) +import UnliftIO.Resource qualified as Resource +import Vulkan.Core10 qualified as Vk +import Vulkan.CStruct.Extends (SomeStruct(..)) +import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..)) +import Vulkan.Zero (zero) + +import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, Queues(..)) + +allocatePools + :: (HasVulkan context, Resource.MonadResource m) + => context + -> m (Resource.ReleaseKey, Queues Vk.CommandPool) +allocatePools context = do + -- context <- ask + bootstrapQueues <- for (getQueues context) \(QueueFamilyIndex ix, _queue) -> do + let + commandPoolCI = Vk.CommandPoolCreateInfo + { flags = zero + , queueFamilyIndex = ix + } + Vk.withCommandPool (getDevice context) commandPoolCI Nothing Resource.allocate + + bqKey <- Resource.register $ + traverse_ (Resource.release . fst) bootstrapQueues + pure (bqKey, fmap snd bootstrapQueues) + +withPools + :: (MonadVulkan env m, MonadResource m) + => (Queues Vk.CommandPool -> m a) + -> m a +withPools action = do + context <- ask + bracket (allocatePools context) (Resource.release . fst) (action . snd) + +-- | Scratch command buffer for transfer operations. +-- The simple fence makes it unusable for rendering. +oneshot_ + :: (HasVulkan context, MonadUnliftIO m) + => context + -> Queues Vk.CommandPool + -> (forall a . Queues a -> a) + -> (Vk.CommandBuffer -> m ()) + -> m () +oneshot_ context commandQueues pickQueue action = + Vk.withCommandBuffers device commandBufferAllocateInfo bracket $ \case + (Vector.toList -> [buf]) -> do + let + oneTime :: Vk.CommandBufferBeginInfo '[] + oneTime = zero + { Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT + } + + Vk.useCommandBuffer buf oneTime $ action buf + + Vk.withFence device zero Nothing bracket $ \fence -> do + Vk.queueSubmit transferQueue (wrap buf) fence + Vk.waitForFences device (pure fence) True maxBound >>= \case + Vk.SUCCESS -> + -- traceM "oneshot_: transfer finished" + pure () + err -> + error $ "copyBuffer failed: " <> show err + _ -> + error "assert: exactly the requested buffer was given" + where + device = getDevice context + transferQueue = snd . pickQueue $ getQueues context + + commandBufferAllocateInfo :: Vk.CommandBufferAllocateInfo + commandBufferAllocateInfo = zero + { Vk.commandPool = pickQueue commandQueues + , Vk.level = Vk.COMMAND_BUFFER_LEVEL_PRIMARY + , Vk.commandBufferCount = 1 + } + + wrap buf = Vector.singleton $ SomeStruct zero + { Vk.commandBuffers = + Vector.singleton (Vk.commandBufferHandle buf) + } diff --git a/src/Resource/Compressed/Zstd.hs b/src/Resource/Compressed/Zstd.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Compressed/Zstd.hs @@ -0,0 +1,39 @@ +module Resource.Compressed.Zstd where + +import RIO + +import RIO.FilePath (takeExtension) +import RIO.ByteString qualified as ByteString + +import Codec.Compression.Zstd qualified as Zstd + +data CompressedError + = EmptyFile FilePath + | ZstdError Text + deriving (Eq, Show) + +instance Exception CompressedError + +fromFileWith :: MonadIO m => (ByteString -> m b) -> (FilePath -> m b) -> FilePath -> m b +fromFileWith withBS withFilePath filePath + | elem (takeExtension filePath) compressedExts = + loadCompressed withBS filePath + | otherwise = + withFilePath filePath + +loadCompressed :: MonadIO m => (ByteString -> m b) -> FilePath -> m b +loadCompressed withBS filePath = do + yeet'd <- ByteString.readFile filePath + case Zstd.decompress yeet'd of + Zstd.Skip -> + throwIO $ EmptyFile filePath + Zstd.Error str -> + throwIO $ ZstdError (fromString str) + Zstd.Decompress buf -> + withBS buf + +compressedExts :: [FilePath] +compressedExts = + [ ".zst" + , ".zstd" + ] diff --git a/src/Resource/DescriptorSet.hs b/src/Resource/DescriptorSet.hs new file mode 100644 --- /dev/null +++ b/src/Resource/DescriptorSet.hs @@ -0,0 +1,32 @@ +module Resource.DescriptorSet + ( allocatePool + , TypeMap + , mkPoolCI + ) where + +import RIO + +import UnliftIO.Resource qualified as Resource +import RIO.Vector qualified as Vector +import Vulkan.Core10 qualified as Vk +import Vulkan.Zero (zero) + +import Engine.Vulkan.Types (HasVulkan(getDevice)) + +allocatePool + :: (Resource.MonadResource m, MonadReader env m, HasVulkan env) + => Word32 -> TypeMap Word32 -> m (Resource.ReleaseKey, Vk.DescriptorPool) +allocatePool maxSets sizes = do + device <- asks getDevice + Vk.withDescriptorPool device (mkPoolCI maxSets sizes) Nothing Resource.allocate + +type TypeMap a = [(Vk.DescriptorType, a)] + +mkPoolCI + :: Word32 + -> TypeMap Word32 + -> Vk.DescriptorPoolCreateInfo '[] +mkPoolCI maxSets sizes = zero + { Vk.maxSets = maxSets + , Vk.poolSizes = Vector.fromList $ map (uncurry Vk.DescriptorPoolSize) sizes + } diff --git a/src/Resource/Image.hs b/src/Resource/Image.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Image.hs @@ -0,0 +1,318 @@ +module Resource.Image where + +import RIO + +import Data.Bits (shiftR, (.|.)) +import RIO.Vector qualified as Vector +import Vulkan.Core10 qualified as Vk +import Vulkan.CStruct.Extends (SomeStruct(..)) +import Vulkan.NamedType ((:::)) +import Vulkan.Utils.Debug qualified as Debug +import Vulkan.Zero (zero) +import VulkanMemoryAllocator qualified as VMA + +import Engine.Vulkan.Types (HasVulkan(..), HasSwapchain(..), Queues(..)) +import Resource.CommandBuffer (oneshot_) + +data AllocatedImage = AllocatedImage + { aiAllocation :: VMA.Allocation + , aiImage :: Vk.Image + , aiImageView :: Vk.ImageView + } + deriving (Show) + +createColorResource + :: ( MonadIO io + , HasVulkan ctx + , HasSwapchain ctx + ) + => ctx + -> Vk.Extent2D + -> io AllocatedImage +createColorResource context Vk.Extent2D{width, height} = do + let + device = getDevice context + allocator = getAllocator context + format = getSurfaceFormat context + msaa = getMultisample context + + (image, allocation, _info) <- VMA.createImage + allocator + (imageCI format msaa) + imageAllocationCI + Debug.nameObject device image "ColorResource.image" + + imageView <- Vk.createImageView + device + (imageViewCI image format) + Nothing + Debug.nameObject device image "ColorResource.view" + + pure AllocatedImage + { aiAllocation = allocation + , aiImage = image + , aiImageView = imageView + } + where + imageCI format msaa = zero + { Vk.imageType = Vk.IMAGE_TYPE_2D + , Vk.format = format + , Vk.extent = Vk.Extent3D width height 1 + , Vk.mipLevels = 1 + , Vk.arrayLayers = 1 + , Vk.tiling = Vk.IMAGE_TILING_OPTIMAL + , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED + , Vk.usage = Vk.IMAGE_USAGE_TRANSIENT_ATTACHMENT_BIT .|. Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT + , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE + , Vk.samples = msaa + } + + imageAllocationCI = zero + { VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY + , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT + } + + imageViewCI image format = zero + { Vk.image = image + , Vk.viewType = Vk.IMAGE_VIEW_TYPE_2D + , Vk.format = format + , Vk.components = zero + , Vk.subresourceRange = subr + } + + subr = zero + { Vk.aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , Vk.baseMipLevel = 0 + , Vk.levelCount = 1 + , Vk.baseArrayLayer = 0 + , Vk.layerCount = 1 + } + +createDepthResource + :: ( MonadIO io + , HasVulkan context + , HasSwapchain context + ) + => context + -> Vk.Extent2D + -> "shadowmap layers" ::: Maybe Word32 + -> io AllocatedImage +createDepthResource context Vk.Extent2D{width, height} depthLayers = do + let + device = getDevice context + allocator = getAllocator context + + depthFormat = getDepthFormat context + msaa = getMultisample context + + (samples, usage, numLayers) = + case depthLayers of + Nothing -> + ( msaa + , Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT + , 1 + ) + Just nl -> + ( Vk.SAMPLE_COUNT_1_BIT + , Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT .|. + Vk.IMAGE_USAGE_SAMPLED_BIT + , nl + ) + + (image, allocation, _info) <- VMA.createImage + allocator + (imageCI depthFormat usage samples numLayers) + imageAllocationCI + Debug.nameObject device image "DepthResource.image" + + imageView <- Vk.createImageView + device + (imageViewCI depthFormat image numLayers) + Nothing + Debug.nameObject device image "DepthResource.view" + + pure AllocatedImage + { aiAllocation = allocation + , aiImage = image + , aiImageView = imageView + } + where + imageCI format usage samples numLayers = zero + { Vk.imageType = Vk.IMAGE_TYPE_2D + , Vk.format = format + , Vk.extent = Vk.Extent3D width height 1 + , Vk.mipLevels = 1 + , Vk.arrayLayers = numLayers + , Vk.tiling = Vk.IMAGE_TILING_OPTIMAL + , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED + , Vk.usage = usage + , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE + , Vk.samples = samples + } + + imageAllocationCI = zero + { VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY + , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT + } + + imageViewCI format image numLayers = zero + { Vk.image = image + , Vk.viewType = viewType + , Vk.format = format + , Vk.components = zero + , Vk.subresourceRange = subr numLayers + } + where + viewType = + if numLayers > 1 then + Vk.IMAGE_VIEW_TYPE_2D_ARRAY + else + Vk.IMAGE_VIEW_TYPE_2D + + subr numLayers = zero + { Vk.aspectMask = Vk.IMAGE_ASPECT_DEPTH_BIT + , Vk.baseMipLevel = 0 + , Vk.levelCount = 1 + , Vk.baseArrayLayer = 0 + , Vk.layerCount = numLayers + } + +destroyAllocatedImage + :: ( MonadIO io + , HasVulkan context + ) + => context + -> AllocatedImage + -> io () +destroyAllocatedImage context AllocatedImage{..} = do + -- traceM "destroyAllocatedImage" + Vk.destroyImageView (getDevice context) aiImageView Nothing + VMA.destroyImage (getAllocator context) aiImage aiAllocation + +-------------------------------------------- + +transitionImageLayout + :: (HasVulkan context) + => context + -> Queues Vk.CommandPool + -> Vk.Image + -> "mip levels" ::: Word32 + -> "layer count" ::: Word32 + -> Vk.Format + -> ("old" ::: Vk.ImageLayout) + -> ("new" ::: Vk.ImageLayout) + -> RIO env () +transitionImageLayout ctx pool image mipLevels layerCount format old new = + case (old, new) of + (Vk.IMAGE_LAYOUT_UNDEFINED, Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL) -> + oneshot_ ctx pool qTransfer \buf -> + Vk.cmdPipelineBarrier + buf + Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT + Vk.PIPELINE_STAGE_TRANSFER_BIT + zero + mempty + mempty + ( Vector.singleton $ + barrier Vk.IMAGE_ASPECT_COLOR_BIT zero Vk.ACCESS_TRANSFER_WRITE_BIT + ) + (Vk.IMAGE_LAYOUT_UNDEFINED, Vk.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL) -> + oneshot_ ctx pool qTransfer \buf -> + Vk.cmdPipelineBarrier + buf + Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT + Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT + zero + mempty + mempty + ( Vector.singleton $ + barrier aspectMask zero $ + Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_READ_BIT .|. + Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT + ) + where + aspectMask = + if hasStencilComponent then + Vk.IMAGE_ASPECT_DEPTH_BIT .|. Vk.IMAGE_ASPECT_STENCIL_BIT + else + Vk.IMAGE_ASPECT_DEPTH_BIT + hasStencilComponent = + format == Vk.FORMAT_D32_SFLOAT_S8_UINT || + format == Vk.FORMAT_D24_UNORM_S8_UINT + + (Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL, Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL) -> + oneshot_ ctx pool qGraphics \buf -> + Vk.cmdPipelineBarrier + buf + Vk.PIPELINE_STAGE_TRANSFER_BIT + Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT + zero + mempty + mempty + ( Vector.singleton $ + barrier + Vk.IMAGE_ASPECT_COLOR_BIT + Vk.ACCESS_TRANSFER_WRITE_BIT + Vk.ACCESS_SHADER_READ_BIT + ) + _ -> + error $ "Unsupported image layout transfer: " <> show (old, new) + where + barrier aspectMask srcMask dstMask = SomeStruct zero + { Vk.srcAccessMask = srcMask + , Vk.dstAccessMask = dstMask + , Vk.oldLayout = old + , Vk.newLayout = new + , Vk.srcQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED + , Vk.dstQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED + , Vk.image = image + , Vk.subresourceRange = subresource aspectMask mipLevels layerCount + } + +subresource + :: Vk.ImageAspectFlags + -> "mip levels" ::: Word32 + -> "layer count" ::: Word32 + -> Vk.ImageSubresourceRange +subresource aspectMask mipLevels layerCount = Vk.ImageSubresourceRange + { aspectMask = aspectMask + , baseMipLevel = 0 + , levelCount = mipLevels -- XXX: including base + , baseArrayLayer = 0 + , layerCount = layerCount + } + +copyBufferToImage + :: (HasVulkan context, Foldable t, Integral deviceSize) + => context + -> Queues Vk.CommandPool + -> Vk.Buffer + -> Vk.Image + -> "base extent" ::: Vk.Extent3D + -> "mip offsets" ::: t deviceSize + -> "layer count" ::: Word32 + -> RIO env () +copyBufferToImage ctx pool src dst Vk.Extent3D{..} mipOffsets layerCount = + oneshot_ ctx pool qTransfer \cmd -> + Vk.cmdCopyBufferToImage cmd src dst Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL $ + Vector.fromList copyRegions + where + copyRegions = do + (offset, mipLevel) <- zip (toList mipOffsets) [0..] + pure Vk.BufferImageCopy + { Vk.bufferOffset = fromIntegral offset + , Vk.bufferRowLength = zero -- XXX: "use extent width" + , Vk.bufferImageHeight = zero -- XXX: "use extent height" + , Vk.imageSubresource = Vk.ImageSubresourceLayers + { aspectMask = Vk.IMAGE_ASPECT_COLOR_BIT + , mipLevel = fromIntegral mipLevel + , baseArrayLayer = 0 + , layerCount = layerCount + } + , Vk.imageOffset = zero + , Vk.imageExtent = Vk.Extent3D + { width = max 1 $ width `shiftR` mipLevel + , height = max 1 $ height `shiftR` mipLevel + , depth = depth + } + } diff --git a/src/Resource/Mesh/Codec.hs b/src/Resource/Mesh/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Mesh/Codec.hs @@ -0,0 +1,340 @@ +module Resource.Mesh.Codec where + +import RIO + +import Codec.Compression.Zstd qualified as Zstd +import Crypto.Hash.MD5 qualified as MD5 +import Data.Binary.Get (runGet) +import Data.Binary.Get qualified as Get +import Data.Binary.Put (runPut) +import Data.Binary.Put qualified as Put +import Data.ByteString.Internal qualified as BSI +import Data.ByteString.Unsafe (unsafePackCStringLen) +import Data.Vector qualified as Vector +import Data.Vector.Generic qualified as Generic +import Data.Vector.Storable qualified as Storable +import Foreign qualified +import Geomancy.Vec3 qualified as Vec3 +import RIO.ByteString qualified as ByteString +import RIO.ByteString.Lazy qualified as BSL +import System.IO.Unsafe (unsafePerformIO) +import UnliftIO.Resource (MonadResource) +import UnliftIO.Resource qualified as Resource +import Vulkan.Core10 qualified as Vk +import Data.Typeable + +import Engine.Vulkan.Types (HasVulkan, Queues) +import Resource.Buffer qualified as Buffer +import Resource.Model qualified as Model + +-- * Format meta + +pattern VER_BREAKS :: Word8 +pattern VER_BREAKS = 2 + +pattern VER_TWEAKS :: Word8 +pattern VER_TWEAKS = 0 + +-- * Encoding + +encodeFile + :: forall vp vi va vn attrs nodes meta env + . ( Generic.Vector vp Vec3.Packed + , Generic.Vector vi Word32 + , Generic.Vector va attrs + , Generic.Vector vn nodes + , Storable attrs + , Storable nodes + , Storable meta + , HasLogFunc env + ) + => FilePath + -> vp Vec3.Packed + -> vi Word32 + -> va attrs + -> vn nodes + -> meta + -> RIO env () +encodeFile fp positions indices attrs nodes meta = do + (posDigest, posCompressed) <- encodeItems positions + logDebug $ "Position digest: " <> displayShow posDigest + + (indDigest, indCompressed) <- encodeItems indices + logDebug $ "Index digest: " <> displayShow indDigest + + (attDigest, attCompressed) <- encodeItems attrs + logDebug $ "Attribute digest: " <> displayShow attDigest + + (nodDigest, nodCompressed) <- encodeItems nodes + logDebug $ "Node digest: " <> displayShow nodDigest + + (metDigest, metCompressed) <- encodeItems $ Storable.singleton meta + logDebug $ "Meta digest: " <> displayShow metDigest + + withFile fp WriteMode \out -> do + BSL.hPut out $ runPut do + -- 0x00 + 4 + 4 + Put.putStringUtf8 "🌋📦" + + -- 0x08 + 1 + 1 + Put.putWord8 VER_BREAKS + Put.putWord8 VER_TWEAKS + + -- 0x0A + 2 + 4 + -- XXX: reserved + Put.putWord16le maxBound + Put.putWord32le maxBound + + -- 0x10 + 4 + 4 + Put.putWord32le . fromIntegral $ Generic.length positions + Put.putWord32le . fromIntegral $ ByteString.length posCompressed + + -- 0x18 + 4 + 4 + Put.putWord32le . fromIntegral $ Generic.length indices + Put.putWord32le . fromIntegral $ ByteString.length indCompressed + + -- 0x20 + 4 + 4 + Put.putWord32le . fromIntegral $ Foreign.sizeOf (error "sizeOf" :: attrs) + Put.putWord32le . fromIntegral $ ByteString.length attCompressed + + -- 0x28 + 4 + 4 + Put.putWord32le . fromIntegral $ Foreign.sizeOf (error "sizeOf" :: nodes) + Put.putWord32le . fromIntegral $ ByteString.length nodCompressed + + -- 0x30 + 4 + 4 + Put.putWord32le . fromIntegral $ Foreign.sizeOf (error "sizeOf" :: meta) + Put.putWord32le . fromIntegral $ ByteString.length metCompressed + + -- 0x38 + 4 + 4 + -- XXX: reserved + Put.putWord32le maxBound + Put.putWord32le maxBound + + -- 0x40 + 16 + 16 + 16 + 16 + 16 + Put.putByteString posDigest + Put.putByteString indDigest + Put.putByteString attDigest + Put.putByteString nodDigest + Put.putByteString metDigest + + -- 0x90 + posCompressed + Put.putByteString posCompressed + + -- 0x90 + posCompressed + indCompressed + Put.putByteString indCompressed + + -- 0x90 + posCompressed + indCompressed + attCompressed + Put.putByteString attCompressed + + -- 0x90 + posCompressed + indCompressed + attCompressed + nodCompressed + Put.putByteString nodCompressed + + -- 0x90 + posCompressed + indCompressed + attCompressed + nodCompressed + metCompressed + Put.putByteString metCompressed + + -- 0x90 + posCompressed + indCompressed + attCompressed + nodCompressed + metCompressed + 4 + 4 + Put.putStringUtf8 "📦🌋" + +encodeItems + :: ( Storable a + , Generic.Vector v a + , MonadIO m + ) + => v a + -> m (ByteString, ByteString) +encodeItems items = do + let bytes = Storable.unsafeCast @_ @Word8 $ Vector.convert items + liftIO $ Storable.unsafeWith bytes \ptr -> do + buf <- unsafePackCStringLen + ( Foreign.castPtr ptr + , Storable.length bytes + ) + let + -- XXX: Process buffer before bytes/ptr go out of scope! + !bufHash = MD5.hash buf + !zBuf = Zstd.compress Zstd.maxCLevel buf + pure (bufHash, zBuf) + +-- * Decoding + +loadIndexed + :: ( Storable attrs + , Storable nodes + , Storable meta + , Show meta + , Typeable nodes + , HasVulkan env + , HasLogFunc env + , MonadResource (RIO env) + ) + => Queues Vk.CommandPool + -> FilePath + -> RIO env + ( Resource.ReleaseKey + , (meta, Storable.Vector nodes, Model.Indexed 'Buffer.Staged Vec3.Packed attrs) + ) +loadIndexed pools fp = do + logInfo $ "Loading " <> fromString fp + (meta, nodes, (positions, indices, attrs)) <- loadBlobs fp + logDebug $ displayShow meta + + logDebug $ "Staging " <> fromString fp + context <- ask + indexed <- Model.createStaged context pools positions attrs indices + key <- Resource.register $ Model.destroyIndexed context indexed + pure (key, (meta, nodes, indexed)) + +loadBlobs + :: forall attrs env nodes meta + . ( Storable attrs + , Storable meta + , Storable nodes + , Typeable nodes + , HasLogFunc env + ) + => FilePath + -> RIO env + ( meta + , Storable.Vector nodes + , ( Storable.Vector Vec3.Packed + , Storable.Vector Word32 + , Storable.Vector attrs + ) + ) +loadBlobs fp = do + blob <- BSL.readFile fp + let + getter = do + magicStart <- Get.getByteString (4+4) + + verBreaks <- Get.getWord8 + verTweaks <- Get.getWord8 + guardEq "Codec version" VER_BREAKS verBreaks + + _reserved16 <- Get.getWord16le + _reserved32 <- Get.getWord32le + + numPositions <- fmap fromIntegral Get.getWord32le + lenPositions <- fmap fromIntegral Get.getWord32le + + numIndices <- fmap fromIntegral Get.getWord32le + lenIndices <- fmap fromIntegral Get.getWord32le + + sizeOfAttr <- fmap fromIntegral Get.getWord32le + lenAttrs <- fmap fromIntegral Get.getWord32le + guardEq "Attribute size" (Foreign.sizeOf (error "sizeOfAttr" :: attrs)) sizeOfAttr + + sizeOfNode <- fmap fromIntegral Get.getWord32le + lenNodes <- fmap fromIntegral Get.getWord32le + guardEq + ("Node size for " <> show (typeRepTyCon . typeRep $ Proxy @nodes)) + (Foreign.sizeOf (error "sizeOfNode" :: nodes)) + sizeOfNode + + sizeOfMeta <- fmap fromIntegral Get.getWord32le + lenMeta <- fmap fromIntegral Get.getWord32le + guardEq "Meta size" (Foreign.sizeOf (error "sizeOf" :: meta)) sizeOfMeta + + _reserved32 <- Get.getWord32le + _reserved32 <- Get.getWord32le + + posDigest <- Get.getByteString 16 + indDigest <- Get.getByteString 16 + attDigest <- Get.getByteString 16 + nodDigest <- Get.getByteString 16 + metDigest <- Get.getByteString 16 + + -- XXX: end for static part for VER_BREAKS + staticDone <- Get.bytesRead + guardEq ("End of static part for v" <> show VER_BREAKS) 0x90 staticDone + + let payloadSize = fromIntegral (lenPositions + lenIndices + lenAttrs + lenNodes + lenMeta) + guardEq "Blob size" (BSL.length blob) $ + staticDone + payloadSize + 4 + 4 + + zPositions <- Get.getByteString lenPositions + zIndices <- Get.getByteString lenIndices + zAttrs <- Get.getByteString lenAttrs + zNodes <- Get.getByteString lenNodes + zMetas <- Get.getByteString lenMeta + + magicFinish <- Get.getByteString (4+4) + + let magicReverse = ByteString.drop 4 magicFinish <> ByteString.take 4 magicFinish + guardEq "Magic final" magicStart magicReverse + + positions <- decodeItems "Positions" posDigest (Just numPositions) zPositions + indices <- decodeItems "Indices" indDigest (Just numIndices) zIndices + attrs <- decodeItems "Attributes" attDigest (Just numPositions) zAttrs + nodes <- decodeItems "Nodes" nodDigest Nothing zNodes + meta <- decodeItems "Metadata" metDigest (Just 1) zMetas + + pure (verTweaks, Storable.head meta, nodes, (positions, indices, attrs)) + + let (verTweaks, meta, nodes, blobs) = runGet getter blob + + when (verTweaks /= VER_TWEAKS) $ + logWarn $ mconcat + [ "Format tweak version mismatch: " + , display verTweaks + , " /= " + , display VER_TWEAKS + ] + + pure (meta, nodes, blobs) + +decodeItems + :: forall item m + . (Storable item, MonadFail m) + => String + -> ByteString + -> Maybe Int + -> ByteString + -> m (Storable.Vector item) +decodeItems label digest expectedSize zBytes = + case Zstd.decompress zBytes of + Zstd.Error err -> + fail err + Zstd.Skip -> do + guardEq (label <> " size") 0 itemSize + case expectedSize of + Just size -> + pure . Storable.replicate size $ + unsafePerformIO (Foreign.peek Foreign.nullPtr) + Nothing -> + pure Storable.empty + Zstd.Decompress bytes -> do + let (buf, bufOff, bufLen) = BSI.toForeignPtr bytes + guardEq (label <> " buffer offset") 0 bufOff + case expectedSize of + Nothing -> + pure () + Just size -> + guardEq (label <> " buffer size") (itemSize * size) bufLen + guardEq (label <> " hash") digest (MD5.hash bytes) + let + !items = + Storable.unsafeCast @Word8 @item $ + Storable.unsafeFromForeignPtr0 buf bufLen + case expectedSize of + Nothing -> + pure () + Just size -> + guardEq (label <> " size") size (Storable.length items) + pure items + where + itemSize = Foreign.sizeOf @item undefined + +-- * Utils + +guardEq :: (MonadFail m, Show a, Eq a) => String -> a -> a -> m () +guardEq label expected got = do + if expected == got then + -- traceM . fromString $ label <> " match: " <> show got + pure () + else + fail $ unlines + [ label <> " mismatch" + , "\tExpected: " <> show expected + , "\tGot : " <> show got + ] diff --git a/src/Resource/Mesh/Types.hs b/src/Resource/Mesh/Types.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Mesh/Types.hs @@ -0,0 +1,305 @@ +{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-} + +module Resource.Mesh.Types + ( AxisAligned(..) + + , Meta(..) + + , NodeGroup(..) + , NodePartitions(..) + + , Nodes + , Node(..) + , TexturedNodes + , TexturedNode(..) + , TextureParams(..) -- XXX: copypasta from LitTextured + + , Measurements(..) + , measureAa + , measureAaWith + , middle + , middleAa + , size + , sizeAa + + , HasRange(..) + ) where + +import RIO + +import Control.Foldl qualified as L +import Foreign (Storable(..), castPtr) +import Foreign.Storable.Generic (GStorable) +import Geomancy (Transform(..), Vec2, Vec4, withVec3) +import Geomancy.Mat4 qualified as Mat4 +import Geomancy.Vec3 qualified as Vec3 +import RIO.Vector.Storable qualified as Storable +import Vulkan.Zero (Zero(..)) + +import Resource.Model (IndexRange(..)) + +data AxisAligned a = AxisAligned + { aaX :: a + , aaY :: a + , aaZ :: a + } + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) + +instance Applicative AxisAligned where + pure x = AxisAligned + { aaX = x + , aaY = x + , aaZ = x + } + + funcs <*> args = AxisAligned + { aaX = aaX funcs $ aaX args + , aaY = aaY funcs $ aaY args + , aaZ = aaZ funcs $ aaZ args + } + +instance Storable a => Storable (AxisAligned a) where + alignment ~_ = alignment (error "AxisAligned.alignment" :: a) + + sizeOf ~_ = 3 * sizeOf (error "AxisAligned.sizeOf" :: a) + + peek ptr = do + aaX <- peekElemOff (castPtr ptr) 0 + aaY <- peekElemOff (castPtr ptr) 1 + aaZ <- peekElemOff (castPtr ptr) 2 + pure AxisAligned{..} + + poke ptr AxisAligned{..} = do + pokeElemOff (castPtr ptr) 0 aaX + pokeElemOff (castPtr ptr) 1 aaY + pokeElemOff (castPtr ptr) 2 aaZ + +-- * Whole-scene metadata + +data Meta = Meta + { -- XXX: full-scene draws + mOpaqueIndices :: IndexRange + , mBlendedIndices :: IndexRange + + -- XXX: per-node draws + , mOpaqueNodes :: IndexRange + , mBlendedNodes :: IndexRange + + , mBoundingSphere :: Vec4 + , mTransformBB :: Transform + , mMeasurements :: AxisAligned Measurements + } + deriving (Show, Generic) + +instance GStorable Meta + +instance Eq Meta where + a == b = and + [ mBoundingSphere a == mBoundingSphere b + , mOpaqueIndices a == mOpaqueIndices b + , mBlendedIndices a == mBlendedIndices b + , mOpaqueNodes a == mOpaqueNodes b + , mBlendedNodes a == mBlendedNodes b + , mMeasurements a == mMeasurements b + + , Mat4.toListRowMajor (mTransformBB a) == + Mat4.toListRowMajor (mTransformBB b) + ] + +-- * Scene parts + +data NodeGroup + = NodeOpaque + | NodeBlended + -- TODO: NodeCutout + deriving (Eq, Ord, Show, Enum, Bounded) + +data NodePartitions a = NodePartitions + { npOpaque :: a + , npBlended :: a + } + deriving (Eq, Show, Functor, Foldable, Traversable) + +type Nodes = Storable.Vector Node + +data Node = Node + { nBoundingSphere :: Vec4 + , nTransformBB :: Transform + , nRange :: IndexRange + , nMeasurements :: AxisAligned Measurements + } + deriving (Show, Generic) + +instance Eq Node where + a == b = and + [ nBoundingSphere a == nBoundingSphere b + , nMeasurements a == nMeasurements b + , nRange a == nRange b + + , Mat4.toListRowMajor (nTransformBB a) == + Mat4.toListRowMajor (nTransformBB b) + ] + +instance GStorable Node + +type TexturedNodes = Storable.Vector TexturedNode + +data TexturedNode = TexturedNode + { tnNode :: Node + , tnBase :: TextureParams + , tnEmissive :: TextureParams + , tnNormal :: TextureParams + , tnOcclusion :: TextureParams + , tnMetallicRoughness :: TextureParams + } + deriving (Eq, Show, Generic) + +instance GStorable TexturedNode + +-- XXX: copypasta from LitTextured.Model +data TextureParams = TextureParams + { tpScale :: Vec2 + , tpOffset :: Vec2 + , tpGamma :: Vec4 + , tpSamplerId :: Int32 + , tpTextureId :: Int32 + } + deriving (Eq, Show, Generic) + +instance Zero TextureParams where + zero = TextureParams + { tpScale = 1 + , tpOffset = 0 + , tpGamma = 1.0 + , tpSamplerId = minBound + , tpTextureId = minBound + } + +instance Storable TextureParams where + alignment ~_ = 4 + + sizeOf ~_ = 8 + 8 + 16 + 4 + 4 + + poke ptr TextureParams{..} = do + pokeByteOff ptr 0 tpScale + pokeByteOff ptr 8 tpOffset + pokeByteOff ptr 16 tpGamma + pokeByteOff ptr 32 tpSamplerId + pokeByteOff ptr 36 tpTextureId + + peek ptr = do + tpScale <- peekByteOff ptr 0 + tpOffset <- peekByteOff ptr 8 + tpGamma <- peekByteOff ptr 16 + tpSamplerId <- peekByteOff ptr 32 + tpTextureId <- peekByteOff ptr 36 + pure TextureParams{..} + +-- * Measurements + +data Measurements = Measurements + { mMin :: Float + , mMax :: Float + , mMean :: Float + , mStd :: Float + } + deriving (Eq, Ord, Show, Generic) + +instance Storable Measurements where + alignment ~_ = 4 -- XXX: 16? + + sizeOf ~_ = 4 * 4 + + peek ptr = do + mMin <- peekByteOff ptr 0 + mMax <- peekByteOff ptr 4 + mMean <- peekByteOff ptr 8 + mStd <- peekByteOff ptr 12 + pure Measurements{..} + + poke ptr Measurements{..} = do + pokeByteOff ptr 0 mMin + pokeByteOff ptr 4 mMax + pokeByteOff ptr 8 mMean + pokeByteOff ptr 12 mStd + +{-# INLINEABLE middleAa #-} +middleAa :: AxisAligned Measurements -> AxisAligned Float +middleAa = fmap middle + +{-# INLINEABLE middle #-} +middle :: Measurements -> Float +middle Measurements{mMax, mMin} = mMin * 0.5 + mMax * 0.5 + +{-# INLINEABLE sizeAa #-} +sizeAa :: AxisAligned Measurements -> AxisAligned Float +sizeAa = fmap size + +{-# INLINEABLE size #-} +size :: Measurements -> Float +size Measurements{mMax, mMin} = mMax - mMin + +measureAaWith + :: (Foldable outer, Foldable inner) + => (a -> inner Vec3.Packed) + -> outer a + -> AxisAligned Measurements +measureAaWith f = L.fold (measureAaWithF f) + +measureAaWithF :: (Foldable t) => (a -> (t Vec3.Packed)) -> L.Fold a (AxisAligned Measurements) +measureAaWithF f = L.premap f (L.handles L.folded measureAaF) + +measureAa :: Foldable t => t Vec3.Packed -> AxisAligned Measurements +measureAa = L.fold measureAaF + +measureAaF :: L.Fold Vec3.Packed (AxisAligned Measurements) +measureAaF = AxisAligned + <$> L.premap packedX measureF + <*> L.premap packedY measureF + <*> L.premap packedZ measureF + +measureF :: L.Fold Float Measurements +measureF = do + mMin <- fmap (fromMaybe 0) L.minimum + mMax <- fmap (fromMaybe 0) L.maximum + mMean <- L.mean + mStd <- L.std + pure Measurements{..} + +-- * Utils + +{-# INLINE packedX #-} +packedX :: Vec3.Packed -> Float +packedX (Vec3.Packed pos) = withVec3 pos \x _y _z -> x + +{-# INLINE packedY #-} +packedY :: Vec3.Packed -> Float +packedY (Vec3.Packed pos) = withVec3 pos \_x y _z -> y + +{-# INLINE packedZ #-} +packedZ :: Vec3.Packed -> Float +packedZ (Vec3.Packed pos) = withVec3 pos \_x _y z -> z + +class HasRange a where + getRange :: a -> IndexRange + adjustRange :: a -> Word32 -> a + +instance HasRange Node where + {-# INLINEABLE getRange #-} + getRange = nRange + + {-# INLINEABLE adjustRange #-} + adjustRange node@Node{nRange} newFirstIndex = node + { nRange = nRange + { irFirstIndex = newFirstIndex + } + } + +instance HasRange TexturedNode where + {-# INLINE getRange #-} + getRange = getRange . tnNode + + {-# INLINE adjustRange #-} + adjustRange tn@TexturedNode{tnNode} newFirstIndex = tn + { tnNode = adjustRange tnNode newFirstIndex + } diff --git a/src/Resource/Mesh/Utils.hs b/src/Resource/Mesh/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Mesh/Utils.hs @@ -0,0 +1,26 @@ +module Resource.Mesh.Utils where + +import RIO + +import RIO.List.Partial (maximum) + +import Geomancy (Transform, Vec4, vec4) +import Geomancy.Transform qualified as Transform + +import Resource.Mesh.Types (AxisAligned(..), Measurements(..), middleAa, sizeAa) + +aabbTranslate :: AxisAligned Measurements -> Transform +aabbTranslate measurements = Transform.translate aaX aaY aaZ + where + AxisAligned{..} = middleAa measurements + +aabbScale :: AxisAligned Measurements -> Transform +aabbScale measurements = Transform.scale3 aaX aaY aaZ + where + AxisAligned{..} = sizeAa measurements + +boundingSphere :: AxisAligned Measurements -> Vec4 +boundingSphere measurements = vec4 aaX aaY aaZ radius + where + AxisAligned{..} = middleAa measurements + radius = maximum (fmap mMax measurements) diff --git a/src/Resource/Model.hs b/src/Resource/Model.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Model.hs @@ -0,0 +1,175 @@ +module Resource.Model where + +import RIO + +import Data.List qualified as List +import Data.Vector.Storable qualified as Storable +import Foreign (Storable(..)) +import Vulkan.Core10 qualified as Vk + +import Engine.Vulkan.Types (HasVulkan(..), Queues(..)) +import Resource.Buffer qualified as Buffer + +data Indexed storage pos attrs = Indexed + { iPositions :: Buffer.Allocated storage pos + , iAttrs :: Buffer.Allocated storage attrs + , iIndices :: Buffer.Allocated storage Word32 + } deriving (Show) + +data Vertex pos attrs = Vertex + { vPosition :: pos + , vAttrs :: attrs + } deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +{-# INLINEABLE vertexAttrs #-} +vertexAttrs :: (pos -> a -> b) -> [Vertex pos a] -> [Vertex pos b] +vertexAttrs inject vertices = do + v@Vertex{..} <- vertices + pure v + { vAttrs = inject vPosition vAttrs + } + +{-# INLINEABLE vertexAttrsPos #-} +vertexAttrsPos :: (pos -> a) -> [pos] -> [Vertex pos a] +vertexAttrsPos inject positions = do + pos <- positions + pure Vertex + { vPosition = pos + , vAttrs = inject pos + } + +class HasVertexBuffers a where + type VertexBuffersOf a + getVertexBuffers :: a -> [Vk.Buffer] + getInstanceCount :: a -> Word32 + +instance HasVertexBuffers () where + type VertexBuffersOf () = () + + {-# INLINE getVertexBuffers #-} + getVertexBuffers () = [] + + {-# INLINE getInstanceCount #-} + getInstanceCount () = 1 + +instance HasVertexBuffers (Buffer.Allocated store a) where + type VertexBuffersOf (Buffer.Allocated store a) = a + + {-# INLINE getVertexBuffers #-} + getVertexBuffers Buffer.Allocated{aBuffer} = [aBuffer] + + {-# INLINE getInstanceCount #-} + getInstanceCount = Buffer.aUsed + +data IndexRange = IndexRange + { irFirstIndex :: Word32 + , irIndexCount :: Word32 + } + deriving (Eq, Ord, Show) + +instance Storable IndexRange where + alignment ~_ = 4 + + sizeOf ~_ = 8 + + peek ptr = do + irFirstIndex <- peekByteOff ptr 0 + irIndexCount <- peekByteOff ptr 4 + pure IndexRange{..} + + poke ptr IndexRange{..} = do + pokeByteOff ptr 0 irFirstIndex + pokeByteOff ptr 4 irIndexCount + +createStagedL + :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io) + => context + -> Queues Vk.CommandPool + -> [Vertex pos attrs] + -> Maybe [Word32] + -> io (Indexed 'Buffer.Staged pos attrs) +createStagedL context pool vertices mindices = createStaged context pool pv av iv + where + pv = Storable.fromList ps + av = Storable.fromList as + + iv = case mindices of + Just is -> + Storable.fromList is + Nothing -> + -- TODO: add vertex deduplication + Storable.generate (Storable.length pv) fromIntegral + + (ps, as) = List.unzip do + Vertex{..} <- vertices + pure (vPosition, vAttrs) + +createStaged + :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io) + => context + -> Queues Vk.CommandPool + -> Storable.Vector pos + -> Storable.Vector attrs + -> Storable.Vector Word32 + -> io (Indexed 'Buffer.Staged pos attrs) +createStaged context pool pv av iv = do + positions <- Buffer.createStaged context pool Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT 0 pv + attrs <- Buffer.createStaged context pool Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT 0 av + indices <- Buffer.createStaged context pool Vk.BUFFER_USAGE_INDEX_BUFFER_BIT 0 iv + pure Indexed + { iPositions = positions + , iAttrs = attrs + , iIndices = indices + } + +createCoherentEmpty + :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io) + => context + -> Int + -> io (Indexed 'Buffer.Coherent pos attrs) +createCoherentEmpty ctx initialSize = Indexed + <$> Buffer.createCoherent ctx Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT initialSize mempty + <*> Buffer.createCoherent ctx Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT initialSize mempty + <*> Buffer.createCoherent ctx Vk.BUFFER_USAGE_INDEX_BUFFER_BIT initialSize mempty + +destroyIndexed + :: (HasVulkan context, MonadUnliftIO io) + => context + -> Indexed storage pos attrs + -> io () +destroyIndexed ctx Indexed{..} = do + Buffer.destroyAll ctx [iPositions] + Buffer.destroyAll ctx [iAttrs] + Buffer.destroyAll ctx [iIndices] + +updateCoherent + :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io) + => context + -> [Vertex pos attrs] + -> Indexed 'Buffer.Coherent pos attrs + -> io (Indexed 'Buffer.Coherent pos attrs) +updateCoherent ctx vertices old = do + Indexed{..} <- pick + Indexed + <$> Buffer.updateCoherent pv iPositions + <*> Buffer.updateCoherent av iAttrs + <*> Buffer.updateCoherent iv iIndices + where + pick = + if oldSize > newSize then + pure old + else do + destroyIndexed ctx old + createCoherentEmpty ctx (max newSize $ oldSize * 2) + + oldSize = Buffer.aCapacity $ iIndices old + newSize = Storable.length pv + + pv = Storable.fromList ps + av = Storable.fromList as + + iv = Storable.generate newSize fromIntegral + + (ps, as) = List.unzip do + Vertex{..} <- vertices + pure (vPosition, vAttrs) diff --git a/src/Resource/Static.hs b/src/Resource/Static.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Static.hs @@ -0,0 +1,132 @@ +module Resource.Static where + +import RIO + +import Data.Char (isDigit, isUpper, toUpper) +import Language.Haskell.TH (Q, Dec) +import Language.Haskell.TH.Syntax (qRunIO) +import RIO.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents) +import RIO.FilePath (combine, joinPath) +import RIO.State (StateT, evalStateT, get, put) + +import qualified Language.Haskell.TH.Syntax as TH +import qualified RIO.List as List +import qualified RIO.Map as Map + +data Scope + = Files + | Dirs + deriving (Eq, Ord, Show, Enum, Bounded, Generic) + +filePaths :: Scope -> FilePath -> Q [Dec] +filePaths = mkDeclsWith mkPattern + where + mkPattern fp fs = do + let name = TH.mkName "paths" + + sigType <- [t| [FilePath] |] + + let + body = TH.ListE do + segments <- List.sort fs + pure . TH.LitE . TH.StringL $ + joinPath (fp : segments) + + pure + [ TH.SigD name sigType + , TH.FunD name [TH.Clause [] (TH.NormalB body) []] + ] + +filePatterns :: Scope -> FilePath -> Q [Dec] +filePatterns = mkDeclsWith mkPattern + where + mkPattern fp fs = + fmap concat $ for fs \segments -> do + let + name = + TH.mkName . map (replace . toUpper) $ + List.intercalate "_" segments + + patType <- [t| FilePath |] + let pat = TH.LitP . TH.StringL $ joinPath (fp : segments) + + pure + [ TH.PatSynSigD name patType + , TH.PatSynD name (TH.PrefixPatSyn []) TH.ImplBidir pat + ] + + replace c = + if isUpper c || isDigit c then + c + else + '_' + +mkDeclsWith + :: (FilePath -> [[String]] -> Q [Dec]) + -> Scope + -> FilePath + -> Q [Dec] +mkDeclsWith mkDecl scope fp = + qRunIO (getFileListPieces scope fp) >>= mkDecl fp + +-- XXX: Initially sourced from yesod-static +getFileListPieces :: Scope -> FilePath -> IO [[String]] +getFileListPieces scope rootPath = evalStateT (go id rootPath) mempty + where + go + :: ([String] -> [String]) + -> String + -> StateT (Map.Map String String) IO [[String]] + go prefixF parentPath = do + let expandPath = combine parentPath + rawContents <- liftIO $ getDirectoryContents parentPath + (dirs, files) <- foldM (partitionContents expandPath) (mempty, mempty) $ + filter notHidden rawContents + + inner <- for dirs \(path, fullPath) -> + go (prefixF . (:) path) fullPath + + let collect = traverse $ traverse dedupe . prefixF . pure + current <- case scope of + Dirs -> + collect $ map snd dirs + Files -> do + collect files + + pure $ concat (current : inner) + + partitionContents expandPath acc@(accDirs, accFiles) path = do + let fullPath = expandPath path + isDir <- doesDirectoryExist fullPath + if isDir then + pure + ( (path, fullPath) : accDirs + , accFiles + ) + else do + isFile <- doesFileExist fullPath + if isFile then + pure + ( accDirs + , path : accFiles + ) + else + -- XXX: skip weird stuff + pure acc + + -- | Reuse data buffers for identical strings + dedupe :: String -> StateT (Map String String) IO String + dedupe s = do + m <- get + case Map.lookup s m of + Just seen -> + pure seen + Nothing -> do + put $ Map.insert s s m + pure s + + notHidden :: FilePath -> Bool + notHidden = \case + "tmp" -> False + '.' : _ -> False + _ -> True diff --git a/src/Resource/Texture.hs b/src/Resource/Texture.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Texture.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Resource.Texture + ( Texture(..) + , destroy + + , TextureError(..) + -- * Texture types + , Flat + , CubeMap + , ArrayOf + , TextureLayers(..) + + -- * Utilities + , allocateCollectionWith + , allocateTextureWith + , debugNameCollection + , TextureLoader + + , createImageView + , imageCI + , imageAllocationCI + , stageBufferCI + , stageAllocationCI + ) where + +import RIO + +import Data.Bits ((.|.)) +import Data.List qualified as List +import GHC.Stack (withFrozenCallStack) +import GHC.TypeLits (Nat, KnownNat, natVal) +import RIO.FilePath (takeBaseName) +import UnliftIO.Resource qualified as Resource +import Vulkan.Core10 qualified as Vk +import Vulkan.NamedType ((:::)) +import Vulkan.Utils.Debug qualified as Debug +import Vulkan.Zero (zero) +import VulkanMemoryAllocator qualified as VMA + +import Engine.Vulkan.Types (HasVulkan(getDevice), MonadVulkan, Queues) +import Resource.Collection qualified as Collection +import Resource.Image (AllocatedImage(..), destroyAllocatedImage, subresource) +import Resource.Image qualified as Image + +data TextureError + = LoadError Int64 Text + | LayerError Word32 Word32 + | MipLevelsError Word32 Int + | ArrayError Word32 Word32 + deriving (Eq, Ord, Show) + +instance Exception TextureError + +data Texture a = Texture + { tFormat :: Vk.Format + , tMipLevels :: Word32 + , tLayers :: Word32 -- ^ Actual number of layers, up to @ArrayOf a@ + , tAllocatedImage :: AllocatedImage + } + deriving (Show) + +data CubeMap +data Flat +data ArrayOf (layers :: Nat) + +-- | Number of expected texture layers to load from resource. +class TextureLayers a where + textureLayers :: Word32 + +instance TextureLayers CubeMap where + textureLayers = 6 + +instance TextureLayers Flat where + textureLayers = 1 + +instance KnownNat n => TextureLayers (ArrayOf n) where + textureLayers = fromInteger $ natVal (Proxy @n) + +type TextureLoader m layers = Vk.Format -> Queues Vk.CommandPool -> FilePath -> m (Texture layers) + +type TextureLoaderAction m layers = FilePath -> m (Texture layers) + +-- * Allocation wrappers + +allocateCollectionWith + :: (Resource.MonadResource m, MonadVulkan env m, Traversable t) + => TextureLoaderAction m layers + -> t FilePath + -> m (Resource.ReleaseKey, t (Texture layers)) +allocateCollectionWith action collection = do + res <- traverse (allocateTextureWith action) collection + key <- Resource.register $ + traverse_ (Resource.release . fst) res + pure (key, fmap snd res) + +allocateTextureWith + :: (Resource.MonadResource m, MonadVulkan env m) + => TextureLoaderAction m layers + -> FilePath + -> m (Resource.ReleaseKey, Texture layers) +allocateTextureWith action path = do + context <- ask + createTexture <- toIO $ action path + Resource.allocate createTexture (destroy context) + +debugNameCollection + :: ( Traversable t + , MonadVulkan env m + , HasLogFunc env + , HasCallStack + ) + => t (Texture layers) + -> t FilePath + -> m () +debugNameCollection textures paths = do + device <- asks getDevice + for_ names \((ix, path), Texture{tAllocatedImage}) -> do + withFrozenCallStack . logDebug $ displayShow (ix, path) + Debug.nameObject device (Image.aiImage tAllocatedImage) $ + fromString $ show @Natural ix <> ":" <> takeBaseName path + where + names = List.zip + (toList $ Collection.enumerate paths) + (toList textures) + +-- * Implementation + +destroy :: (MonadIO io, HasVulkan context) => context -> Texture a -> io () +destroy context Texture{tAllocatedImage} = + destroyAllocatedImage context tAllocatedImage + +createImageView + :: (MonadIO io, HasVulkan context) + => context + -> Vk.Image + -> Vk.Format + -> "mip levels" ::: Word32 + -> "array layers" ::: Word32 + -> io Vk.ImageView +createImageView context image format mipLevels arrayLayers = + Vk.createImageView (getDevice context) imageViewCI Nothing + where + imageViewCI = zero + { Vk.image = image + , Vk.viewType = viewType + , Vk.format = format + , Vk.components = zero + , Vk.subresourceRange = colorRange + } + + viewType = + if arrayLayers == 6 then + Vk.IMAGE_VIEW_TYPE_CUBE + else + Vk.IMAGE_VIEW_TYPE_2D + + colorRange = + subresource Vk.IMAGE_ASPECT_COLOR_BIT mipLevels arrayLayers + +imageCI :: Vk.Format -> Vk.Extent3D -> Word32 -> Word32 -> Vk.ImageCreateInfo '[] +imageCI format extent mipLevels arrayLayers = zero + { Vk.flags = flags + , Vk.imageType = Vk.IMAGE_TYPE_2D + , Vk.format = format + , Vk.extent = extent + , Vk.mipLevels = mipLevels + , Vk.arrayLayers = if isCube then 6 else arrayLayers + , Vk.tiling = Vk.IMAGE_TILING_OPTIMAL + , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED + , Vk.usage = usage + , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE + , Vk.samples = Vk.SAMPLE_COUNT_1_BIT -- XXX: no multisampling here + } + where + isCube = + arrayLayers == 6 + + usage = + Vk.IMAGE_USAGE_SAMPLED_BIT .|. -- Sampler + Vk.IMAGE_USAGE_TRANSFER_DST_BIT -- Staging + + flags = + if isCube then + Vk.IMAGE_CREATE_CUBE_COMPATIBLE_BIT + else + zero + +imageAllocationCI :: VMA.AllocationCreateInfo +imageAllocationCI = zero + { VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY + , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT + } + +stageBufferCI :: Integral a => a -> Vk.BufferCreateInfo '[] +stageBufferCI pixelBytes = zero + { Vk.size = fromIntegral pixelBytes + , Vk.usage = Vk.BUFFER_USAGE_TRANSFER_SRC_BIT + , Vk.sharingMode = Vk.SHARING_MODE_EXCLUSIVE + } + +stageAllocationCI :: VMA.AllocationCreateInfo +stageAllocationCI = zero + { VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT + , VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU + , VMA.requiredFlags = Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT + } diff --git a/src/Resource/Texture/Ktx1.hs b/src/Resource/Texture/Ktx1.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Texture/Ktx1.hs @@ -0,0 +1,197 @@ +module Resource.Texture.Ktx1 + ( createTexture + ) where + +import RIO + +import Codec.Ktx qualified as Ktx1 +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.Text qualified as Text +import Data.Vector qualified as Vector +import Foreign qualified +import Vulkan.Core10 qualified as Vk +import Vulkan.Utils.FromGL qualified as FromGL +import VulkanMemoryAllocator qualified as VMA + +import Engine.Types (StageRIO) +import Engine.Vulkan.Types (HasVulkan(..), Queues) +import Resource.Compressed.Zstd qualified as Zstd +import Resource.Image (AllocatedImage(..)) +import Resource.Image qualified as Image +import Resource.Texture (Texture(..), TextureLayers(..)) +import Resource.Texture qualified as Texture + +createTexture + :: forall a st . (TextureLayers a) + => Queues Vk.CommandPool + -> FilePath + -> StageRIO st (Texture a) +createTexture pool path = do + context <- ask + let vma = getAllocator context + + logInfo $ "Loading " <> fromString path + loader path >>= \case + Left (offset, err) -> do + logError $ "Texture load error: " <> fromString err + throwM $ Texture.LoadError offset (Text.pack err) + Right Ktx1.Ktx{header, images=ktxImages} -> do + let + skipMips = 0 -- DEBUG: Vector.length ktxImages `div` 2 + mipsSkipped = min (Vector.length ktxImages - 1) skipMips + images = Vector.drop mipsSkipped ktxImages + mipLevels = Ktx1.numberOfMipmapLevels header - fromIntegral mipsSkipped + + when (Vector.null images) $ + throwM $ Texture.LoadError 0 "At least one image must be present in KTX" + + unless (fromIntegral mipLevels == Vector.length images) $ + throwM $ Texture.MipLevelsError mipLevels (Vector.length images) + + -- XXX: https://github.com/KhronosGroup/KTX-Software/blob/bf849b7f/lib/vk_format.h#L676 + format <- case Ktx1.glInternalFormat header of + -- XXX: Force all BC7s to SRGB + 36492 -> + pure Vk.FORMAT_BC7_SRGB_BLOCK + other -> + case FromGL.internalFormat other of + Nothing -> + error $ "Unexpected glInternalFormat: " <> show other -- TODO: throwIo + Just fmt -> + -- XXX: going in blind + pure fmt + logDebug $ mconcat + [ "Loading format " + , display $ Ktx1.glInternalFormat header + , " as " + , displayShow format + ] + + -- XXX: https://github.com/KhronosGroup/KTX-Software/blob/bf849b7f/lib/vkloader.c#L552 + let + extent = Vk.Extent3D + { Vk.width = Ktx1.pixelWidth header `Foreign.shiftR` mipsSkipped + , Vk.height = Ktx1.pixelHeight header `Foreign.shiftR` mipsSkipped + , Vk.depth = max 1 $ Ktx1.pixelDepth header + } + arrayLayers = max 1 $ Ktx1.numberOfArrayElements header + + -- TODO: basisu can encode movies as arrays, this could be handy + unless (arrayLayers == 1) do + logError "TODO: arrayLayers > 1" + throwM $ Texture.ArrayError 1 arrayLayers + + let + numLayers = Ktx1.numberOfFaces header + mipSizes = fmap ((*) numLayers . Ktx1.imageSize) images + + offsets' = Vector.scanl' (+) 0 mipSizes + totalSize = Vector.last offsets' + offsets = Vector.init offsets' + + logDebug $ "mipSizes: " <> displayShow mipSizes + logDebug $ "offsets: " <> displayShow offsets + + {- XXX: + Image created before staging buffer due to `Image.copyBufferToImage` + issued inside `VMA.withBuffer` bracket. + -} + (image, allocation, _info) <- VMA.createImage + vma + (Texture.imageCI format extent mipLevels numLayers) + Texture.imageAllocationCI + + Image.transitionImageLayout + context + pool + image + mipLevels + numLayers -- XXX: arrayLayers is always 0 for now + format + Vk.IMAGE_LAYOUT_UNDEFINED + Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + + unless (numLayers == textureLayers @a) $ + throwM $ Texture.ArrayError (textureLayers @a) numLayers + + VMA.withBuffer vma (Texture.stageBufferCI totalSize) Texture.stageAllocationCI bracket \(staging, stage, stageInfo) -> do + let ixMipImages = Vector.zip3 (Vector.fromList [0..]) offsets images + Vector.forM_ ixMipImages \(mipIx, offset, Ktx1.MipLevel{imageSize, arrayElements}) -> do + let ixArrayElements = Vector.zip (Vector.fromList [0..]) arrayElements + Vector.forM_ ixArrayElements \(arrayIx, Ktx1.ArrayElement{faces}) -> do + let ixFaces = Vector.zip (Vector.fromList [0..]) faces + Vector.forM_ ixFaces \(faceIx, Ktx1.Face{zSlices}) -> do + let ixSlices = Vector.zip (Vector.fromList [0..]) zSlices + Vector.forM_ ixSlices \(sliceIx, Ktx1.ZSlice{block}) -> do + let + indices = mconcat + [ "[" + , " mip:" <> display @Word32 mipIx + , " arr:" <> display @Word32 arrayIx + , " fac:" <> display @Word32 faceIx + , " slc:" <> display @Word32 sliceIx + , " ]" + ] + let blockOffset = offset + faceIx * imageSize + let sectionPtr = Foreign.plusPtr (VMA.mappedData stageInfo) (fromIntegral blockOffset) + logDebug $ mconcat + [ indices + , " base offset = " + , display offset + , " image offset = " + , display $ faceIx * imageSize + , " image size = " + , display imageSize + ] + liftIO $ unsafeUseAsCStringLen block \(pixelsPtr, pixelBytes) -> do + if pixelBytes /= fromIntegral imageSize then + error "assert: MipLevel.imageSize matches block.pixelBytes" + else + -- traceShowM (sectionPtr, pixelBytes) + Foreign.copyBytes sectionPtr (Foreign.castPtr pixelsPtr) pixelBytes + + VMA.flushAllocation vma stage 0 Vk.WHOLE_SIZE + + -- XXX: copying to image while the staging buffer is still alive + Image.copyBufferToImage + context + pool + staging + image + extent + offsets + numLayers + + -- XXX: staging buffer is gone + + Image.transitionImageLayout + context + pool + image + mipLevels + numLayers -- XXX: arrayLayers is always 0 for now + format + Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL + + imageView <- Texture.createImageView + context + image + format + mipLevels + numLayers + + let + allocatedImage = AllocatedImage + { aiAllocation = allocation + , aiImage = image + , aiImageView = imageView + } + pure Texture + { tFormat = format + , tMipLevels = mipLevels + , tLayers = numLayers + , tAllocatedImage = allocatedImage + } + where + loader = liftIO . Zstd.fromFileWith (pure . Ktx1.fromByteString) Ktx1.fromFile