diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,28 @@ # Changelog for keid-core +## 0.1.8.0 + +Massive ~~breakage~~ fixing around allocate/create/destroy patterns and naming things. + +- Deleted `Resource.DescriptorSets`. +- Added `Resource.Vulkan.DescriptorPool`. +- Renamed `Engine.Vulkan.Types.DsBindings` to `DsLayoutBindings`. +- Added `allocate_` for `Engine.Vulkan.Pipeline.Graphics` and `Compute`. +- Added `size`, `withSize` and experimental `HasField` instance for `Resource.Texture`. +- Fixed SPIR-V signatures compatibility by hiding builtin interface vars. +- `Engine.Worker.spawn*` and `Engine.Events.*` handlers and now self-registereing. +- Due to `RunState`/`Sink RunState` loop callbacks now use a `MonadSink rs m` instead of `StageRIO rs`. +- Added `Resource.Texture.Ktx2`. + * It lacks the BC7 hack to force sRGB for compressed textures as it is possible to set the correct format directly. +- Moved Base textures to KTX2 containers. KTX1 is soft-deprecated. +- Graphics pipelines now able to fill the config automatically with `Graphics.vertexInput` helper. Using: + * `HasVertexInputBindings` class that provides attribute bindings. + * `HasVkFormat` class to generate bindings parameters automatically (with generics) or explicitly. + * `vertexFormat`, `instanceFormat` helpers for using `HasVkFormat` to provide `HasVertexInputBindings` instances. +- Added `Resource.Model.Observer` that wraps coherent buffers and is able to observe multi-buffered resources. +- Changed `Swapchain.setDynamicFullscreen` to accept a frame directly. +- Added `MonadReader` and `MonadState` instances for `Bound` to allow fetching models at draw call site. + ## 0.1.7.2 - Added `--size` option to set the initial window size. diff --git a/keid-core.cabal b/keid-core.cabal --- a/keid-core.cabal +++ b/keid-core.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack name: keid-core -version: 0.1.7.2 +version: 0.1.8.0 synopsis: Core parts of Keid engine. category: Game Engine homepage: https://keid.haskell-game.dev @@ -52,6 +52,7 @@ Engine.UI.Layout Engine.UI.Layout.Linear Engine.Vulkan.DescSets + Engine.Vulkan.Format Engine.Vulkan.Pipeline Engine.Vulkan.Pipeline.Compute Engine.Vulkan.Pipeline.External @@ -79,18 +80,23 @@ Resource.Combined.Textures Resource.CommandBuffer Resource.Compressed.Zstd - Resource.DescriptorSet Resource.Image Resource.Image.Atlas Resource.Mesh.Codec Resource.Mesh.Types Resource.Mesh.Utils Resource.Model + Resource.Model.Observer + Resource.Model.Observer.Example Resource.Region Resource.Source Resource.Static Resource.Texture Resource.Texture.Ktx1 + Resource.Texture.Ktx2 + Resource.Vulkan.DescriptorLayout + Resource.Vulkan.DescriptorPool + Resource.Vulkan.Named other-modules: Paths_keid_core hs-source-dirs: @@ -167,7 +173,7 @@ , file-embed , foldl , geomancy - , ktx-codec + , ktx-codec >=0.0.2.0 , neat-interpolation , optparse-applicative , optparse-simple diff --git a/src/Engine/Camera.hs b/src/Engine/Camera.hs --- a/src/Engine/Camera.hs +++ b/src/Engine/Camera.hs @@ -32,6 +32,8 @@ import Geomancy.Vec3 qualified as Vec3 import Geomancy.Vulkan.Projection qualified as Projection import Geomancy.Vulkan.View qualified as View +import RIO.App (App) +import UnliftIO.Resource (MonadResource) import Vulkan.Core10 qualified as Vk import Vulkan.NamedType ((:::)) @@ -67,9 +69,13 @@ ProjectionParams 'Orthographic = () spawnProjection - :: (Vk.Extent2D -> ProjectionInput pk -> Transform) + :: ( MonadReader (App Engine.GlobalHandles st) m + , MonadResource m + , MonadUnliftIO m + ) + => (Vk.Extent2D -> ProjectionInput pk -> Transform) -> ProjectionParams pk - -> Engine.StageRIO env (ProjectionProcess pk) + -> m (ProjectionProcess pk) spawnProjection mkTransform params = spawnProjectionWith mkTransform ProjectionInput { projectionNear = PROJECTION_NEAR @@ -84,9 +90,13 @@ pattern PROJECTION_FAR = 16384 spawnProjectionWith - :: (Vk.Extent2D -> ProjectionInput pk -> Transform) + :: ( MonadReader (App Engine.GlobalHandles st) m + , MonadResource m + , MonadUnliftIO m + ) + => (Vk.Extent2D -> ProjectionInput pk -> Transform) -> ProjectionInput pk - -> Engine.StageRIO env (ProjectionProcess pk) + -> m (ProjectionProcess pk) spawnProjectionWith mkTransform projectionInput = do screen <- Engine.askScreenVar input <- Worker.newVar projectionInput @@ -104,7 +114,12 @@ screen input -spawnPerspective :: Engine.StageRIO env (ProjectionProcess 'Perspective) +spawnPerspective + :: ( MonadReader (App Engine.GlobalHandles st) m + , MonadResource m + , MonadUnliftIO m + ) + => m (ProjectionProcess 'Perspective) spawnPerspective = spawnProjection mkTransformPerspective (τ / 4) mkTransformPerspective :: Vk.Extent2D -> ProjectionInput 'Perspective -> Transform @@ -116,7 +131,12 @@ width height -spawnOrthoPixelsCentered :: Engine.StageRIO env (ProjectionProcess 'Orthographic) +spawnOrthoPixelsCentered + :: ( MonadReader (App Engine.GlobalHandles st) m + , MonadResource m + , MonadUnliftIO m + ) + => m (ProjectionProcess 'Orthographic) spawnOrthoPixelsCentered = spawnProjectionWith mkTransformOrthoPixelsCentered ProjectionInput { projectionNear = 0 , projectionFar = 1 diff --git a/src/Engine/Camera/Controls.hs b/src/Engine/Camera/Controls.hs --- a/src/Engine/Camera/Controls.hs +++ b/src/Engine/Camera/Controls.hs @@ -16,8 +16,14 @@ import Engine.Worker qualified as Worker import Geomancy (Vec3, vec3) import Geomancy.Quaternion qualified as Quaternion +import UnliftIO.Resource (MonadResource) -spawnViewOrbital :: Camera.ViewOrbitalInput -> RIO env Camera.ViewProcess +spawnViewOrbital + :: ( MonadResource m + , MonadUnliftIO m + ) + => Camera.ViewOrbitalInput + -> m Camera.ViewProcess spawnViewOrbital = Worker.spawnCell Camera.mkViewOrbital_ data Controls a = Controls @@ -30,7 +36,12 @@ type ControlsProcess = Controls (Worker.Timed Float ()) -spawnControls :: Camera.ViewProcess -> RIO env ControlsProcess +spawnControls + :: ( MonadResource m + , MonadUnliftIO m + ) + => Camera.ViewProcess + -> m ControlsProcess spawnControls vp = traverse mkUpdater Controls { panHorizontal = panTargetHorizontal diff --git a/src/Engine/Events.hs b/src/Engine/Events.hs --- a/src/Engine/Events.hs +++ b/src/Engine/Events.hs @@ -6,17 +6,17 @@ import RIO -import UnliftIO.Resource (ReleaseKey) +import UnliftIO.Resource (MonadResource, ReleaseKey) import UnliftIO.Resource qualified as Resource -import Engine.Events.Sink (Sink) +import Engine.Events.Sink (MonadSink, 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) + :: MonadSink st m + => (event -> m ()) + -> [Sink event st -> m ReleaseKey] + -> m (ReleaseKey, Sink event st) spawn handleEvent sources = do (sinkKey, sink) <- Sink.spawn handleEvent @@ -26,7 +26,10 @@ pure (key, sink) -registerMany :: [StageRIO st ReleaseKey] -> StageRIO st ReleaseKey +registerMany + :: MonadResource m + => [m ReleaseKey] + -> m ReleaseKey registerMany actions = sequenceA actions >>= Resource.register . traverse_ Resource.release diff --git a/src/Engine/Events/CursorPos.hs b/src/Engine/Events/CursorPos.hs --- a/src/Engine/Events/CursorPos.hs +++ b/src/Engine/Events/CursorPos.hs @@ -4,33 +4,33 @@ import Geomancy (Vec2, vec2, pattern WithVec2) import GHC.Float (double2Float) -import UnliftIO.Resource (ReleaseKey) +import UnliftIO.Resource (MonadResource, ReleaseKey) import Vulkan.Core10 qualified as Vk import Vulkan.NamedType ((:::)) -import Engine.Types (StageRIO, askScreenVar) +import Engine.Events.Sink (MonadSink, Sink) +import Engine.Types (askScreenVar) import Engine.Window.CursorPos qualified as CursorPos import Engine.Worker qualified as Worker -import Engine.Events (Sink) - callback - :: ( Worker.HasInput cursor + :: ( MonadSink rs m + , Worker.HasInput cursor , Worker.GetInput cursor ~ Vec2 ) => cursor - ------------------------- - -> Sink e rs - -> StageRIO rs ReleaseKey + -> Sink e st + -> m ReleaseKey callback cursorVar = CursorPos.callback . handler cursorVar handler - :: ( Worker.HasInput cursor + :: ( MonadResource m + , Worker.HasInput cursor , Worker.GetInput cursor ~ Vec2 ) => cursor - -> Sink e rs - -> CursorPos.Callback rs + -> Sink e st + -> CursorPos.Callback m handler cursorVar _sink windowX windowY = do -- logDebug $ "CursorPos event: " <> displayShow (windowX, windowY) Worker.pushInput cursorVar \_old -> @@ -38,7 +38,9 @@ type Process = Worker.Cell ("window" ::: Vec2) ("centered" ::: Vec2) -spawn :: StageRIO env Process +spawn + :: MonadSink rs m + => m Process spawn = do screen <- askScreenVar cursorWindow <- Worker.newVar 0 diff --git a/src/Engine/Events/MouseButton.hs b/src/Engine/Events/MouseButton.hs --- a/src/Engine/Events/MouseButton.hs +++ b/src/Engine/Events/MouseButton.hs @@ -9,38 +9,39 @@ import Geomancy (Vec2) import UnliftIO.Resource (ReleaseKey) -import Engine.Events.Sink (Sink) -import Engine.Types (StageRIO) +import Engine.Events.Sink (MonadSink, Sink) import Engine.Window.MouseButton (ModifierKeys, MouseButton, MouseButtonState) import Engine.Window.MouseButton qualified as MouseButton import Engine.Worker qualified as Worker -type ClickHandler e st = +type ClickHandler e st m = Sink e st -> Vec2 -> (ModifierKeys, MouseButtonState, MouseButton) -> - StageRIO st () + m () callback - :: ( Worker.HasOutput cursor + :: ( MonadSink rs m + , Worker.HasOutput cursor , Worker.GetOutput cursor ~ Vec2 ) => cursor - -> ClickHandler e st + -> ClickHandler e st m ------------------------- -> Sink e st - -> StageRIO st ReleaseKey + -> m ReleaseKey callback cursorP eventHandler = MouseButton.callback . handler cursorP eventHandler handler - :: ( Worker.HasOutput cursor + :: ( MonadSink rs m + , Worker.HasOutput cursor , Worker.GetOutput cursor ~ Vec2 ) => cursor - -> ClickHandler e st + -> ClickHandler e st m -> Sink e st -> (ModifierKeys, MouseButtonState, MouseButton) - -> StageRIO st () + -> m () handler cursorP eventHandler sink buttonEvent = do cursorPos <- Worker.getOutputData cursorP logDebug $ "MouseButton event: " <> displayShow (cursorPos, buttonEvent) diff --git a/src/Engine/Events/Sink.hs b/src/Engine/Events/Sink.hs --- a/src/Engine/Events/Sink.hs +++ b/src/Engine/Events/Sink.hs @@ -1,28 +1,41 @@ module Engine.Events.Sink ( Sink(..) , spawn + + , MonadSink ) where import RIO import Control.Concurrent.Chan.Unagi qualified as Unagi import Control.Exception (AsyncException(ThreadKilled)) +import Engine.Types (GlobalHandles) +import RIO.App (App) +import RIO.State (MonadState) import UnliftIO.Concurrent (forkFinally, killThread) -import UnliftIO.Resource (ReleaseKey) +import UnliftIO.Resource (ReleaseKey, MonadResource) import UnliftIO.Resource qualified as Resource -import Engine.Types (StageRIO) +-- | A collection of properties that are available while handling events. +-- Has access to a stage @RunState@, but not @Frame@ data. +type MonadSink rs m = + ( MonadReader (App GlobalHandles rs) m + , MonadState rs m + , MonadResource m + , MonadUnliftIO m + ) -newtype Sink event st = Sink - { signal :: event -> StageRIO st () +newtype Sink event rs = Sink + { signal :: forall m . MonadSink rs m => event -> m () } spawn - :: (event -> StageRIO rs ()) - -> StageRIO rs (ReleaseKey, Sink event rs) + :: MonadSink rs m + => (event -> m ()) + -> m (ReleaseKey, Sink event rs) spawn handleEvent = do (eventsIn, eventsOut) <- liftIO Unagi.newChan - let sink = Sink \event -> liftIO (Unagi.writeChan eventsIn event) + let sink = Sink $ liftIO . Unagi.writeChan eventsIn let handler = forever $ diff --git a/src/Engine/Frame.hs b/src/Engine/Frame.hs --- a/src/Engine/Frame.hs +++ b/src/Engine/Frame.hs @@ -29,6 +29,7 @@ import Engine.DataRecycler (DumpResource, WaitResource) import Engine.Setup.Window qualified as Window import Engine.Types (GlobalHandles(..), StageRIO, Stage(..), Frame(..), GPUWork, RecycledResources(..)) +import Engine.Types.Options (optionsPresent, optionsMsaa) import Engine.Types.RefCounted (newRefCounted) import Engine.Vulkan.Swapchain (SwapchainResources(..), SwapchainInfo(..), allocSwapchainResources, recreateSwapchainResources) import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, RenderPass(..), Queues) @@ -44,11 +45,17 @@ GlobalHandles{..} <- asks appEnv let device = ghDevice + let + fPresent = optionsPresent ghOptions + fMSAA = optionsMsaa ghOptions + sfSwapchainResources <- case oldSR of Nothing -> do windowSize <- liftIO $ Window.getExtent2D ghWindow let oldSwapchain = Vk.NULL_HANDLE allocSwapchainResources + fPresent + fMSAA oldSwapchain windowSize ghSurface @@ -168,6 +175,8 @@ , fPipelines = fPipelines f , fRenderFinishedHostSemaphore = fRenderFinishedHostSemaphore f , fStageResources = fStageResources f + , fPresent = fPresent f + , fMSAA = fMSAA f , fSwapchainResources , fRenderpass , fGPUWork @@ -178,7 +187,7 @@ getNext Frame{..} = do if needsNewSwapchain then do windowSize <- liftIO $ Window.getExtent2D fWindow - newResources <- recreateSwapchainResources windowSize fSwapchainResources + newResources <- recreateSwapchainResources fPresent fMSAA windowSize fSwapchainResources let formatMatch = diff --git a/src/Engine/Render.hs b/src/Engine/Render.hs --- a/src/Engine/Render.hs +++ b/src/Engine/Render.hs @@ -7,6 +7,7 @@ import Control.Monad.Trans.Resource qualified as Resource import Vulkan.Core10 qualified as Vk +import Vulkan.Core10.CommandBuffer qualified as CommandBuffer 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 @@ -65,8 +66,8 @@ let commandBufferBI = zero - { Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT - } :: Vk.CommandBufferBeginInfo '[] + { CommandBuffer.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT + } Vk.useCommandBuffer commandBuffer commandBufferBI $ recordCommandBuffer commandBuffer stageRecycled imageIndex diff --git a/src/Engine/Setup.hs b/src/Engine/Setup.hs --- a/src/Engine/Setup.hs +++ b/src/Engine/Setup.hs @@ -15,6 +15,7 @@ import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..)) import Vulkan.Zero (zero) import VulkanMemoryAllocator qualified as VMA +import Vulkan.Core12 (pattern API_VERSION_1_2) #if MIN_VERSION_vulkan(3,15,0) import Foreign.Ptr (castFunPtr) @@ -47,10 +48,18 @@ "Keid Engine" logDebug "Creating instance" + let + appInfo = Vk.ApplicationInfo + { apiVersion = API_VERSION_1_2 + , applicationName = Nothing + , applicationVersion = 0 + , engineName = Nothing + , engineVersion = 0 + } ghInstance <- createInstanceFromRequirements (deviceProps : debugUtils : windowReqs) mempty - zero + (zero { Vk.applicationInfo = Just appInfo }) logDebug "Creating surface" (_surfaceKey, ghSurface) <- Window.allocateSurface ghWindow ghInstance diff --git a/src/Engine/Setup/Device.hs b/src/Engine/Setup/Device.hs --- a/src/Engine/Setup/Device.hs +++ b/src/Engine/Setup/Device.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedRecordDot #-} + -- | Physical device tools module Engine.Setup.Device where @@ -122,9 +124,7 @@ pdiTotalMemory <- do props <- Vk.getPhysicalDeviceMemoryProperties phys pure . sum $ - fmap - (Vk.size :: Vk.MemoryHeap -> Vk.DeviceSize) - (Vk.memoryHeaps props) + fmap (.size) (Vk.memoryHeaps props) pdiProperties <- Vk.getPhysicalDeviceProperties phys @@ -185,8 +185,6 @@ hasFeat <- getPhysicalDeviceFeatures2KHR phys >>= \case _ ::& (PhysicalDeviceTimelineSemaphoreFeatures hasTimelineSemaphores :& ()) -> pure hasTimelineSemaphores - _ -> - pure False pure $ hasExt && hasFeat diff --git a/src/Engine/SpirV/Compile.hs b/src/Engine/SpirV/Compile.hs --- a/src/Engine/SpirV/Compile.hs +++ b/src/Engine/SpirV/Compile.hs @@ -13,7 +13,7 @@ import RIO.Process (HasProcessContext, proc, readProcess_) import RIO.Text qualified as Text -import Render.Code (Code(..)) +import Render.Code (Code(..), targetEnv) import Engine.Vulkan.Pipeline.Stages qualified as Stages glsl @@ -44,7 +44,7 @@ ByteString.writeFile shaderFile outBytes (_out, _err) <- proc "glslangValidator" - [ "--target-env", "vulkan1.2" + [ "--target-env", targetEnv , "-S", Text.unpack stage , "-V", shaderFile , "-o", outFile diff --git a/src/Engine/SpirV/Reflect.hs b/src/Engine/SpirV/Reflect.hs --- a/src/Engine/SpirV/Reflect.hs +++ b/src/Engine/SpirV/Reflect.hs @@ -216,12 +216,11 @@ deriving (Eq, Ord, Show) stagesInterfaceMap - :: ( MonadIO m - , Traversable stages + :: ( Traversable stages ) => stages (Maybe Module) - -> m (StageInterface stages) -stagesInterfaceMap = traverse $ traverse (pure . moduleInterfaceBinds) + -> StageInterface stages +stagesInterfaceMap = fmap (fmap moduleInterfaceBinds) moduleInterfaceBinds :: Module -> (InterfaceBinds, InterfaceBinds) moduleInterfaceBinds refl = @@ -233,6 +232,9 @@ interfaceBinds cls vars = IntMap.fromList do var@InterfaceVariable.InterfaceVariable{location} <- toList vars guard $ InterfaceVariable.storage_class var == cls + + -- XXX: Remove vars like @gl_FragCoord@/@SV_Position@ from potential signatures. + guard $ InterfaceVariable.built_in var == maxBound let td = InterfaceVariable.type_description var diff --git a/src/Engine/Types.hs b/src/Engine/Types.hs --- a/src/Engine/Types.hs +++ b/src/Engine/Types.hs @@ -4,6 +4,7 @@ import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Resource qualified as ResourceT +import Data.Kind (Type) import Graphics.UI.GLFW qualified as GLFW import RIO.App (App, appEnv, appState) import RIO.Lens (_1) @@ -15,12 +16,12 @@ import VulkanMemoryAllocator qualified as VMA import Engine.Setup.Window (Window) +import Engine.Types.Options (Options) import Engine.Types.RefCounted (RefCounted) import Engine.Vulkan.Swapchain (SwapchainResources(..)) -import Engine.Vulkan.Types (HasVulkan(..)) +import Engine.Vulkan.Types (HasVulkan(..), HasSwapchain(..)) import Engine.Vulkan.Types qualified as Vulkan import Engine.Worker qualified as Worker -import Engine.Types.Options (Options) -- * App globals @@ -39,7 +40,10 @@ , ghStageSwitch :: StageSwitchVar } -askScreenVar :: StageRIO env (Worker.Var Vk.Extent2D) +{-# INLINE askScreenVar #-} +askScreenVar + :: MonadReader (App GlobalHandles st) m + => m (Worker.Var Vk.Extent2D) askScreenVar = asks $ ghScreenVar . appEnv instance HasVulkan GlobalHandles where @@ -118,10 +122,13 @@ -- | 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 + { fIndex :: Word64 -- ^ Which number frame is this + , fWindow :: Window + , fSurface :: Khr.SurfaceKHR + , fPresent :: Maybe Khr.PresentModeKHR + , fMSAA :: Vk.SampleCountFlagBits + , fSwapchainResources :: SwapchainResources , fRenderpass :: renderpass , fPipelines :: pipelines @@ -154,6 +161,24 @@ -} } +instance HasSwapchain (Frame renderpass pipelines resources) where + getSurfaceExtent = getSurfaceExtent . fSwapchainResources + getSurfaceFormat = getSurfaceFormat . fSwapchainResources + getDepthFormat = getDepthFormat . fSwapchainResources + getMultisample = getMultisample . fSwapchainResources + getAnisotropy = getAnisotropy . fSwapchainResources + getSwapchainViews = getSwapchainViews . fSwapchainResources + getMinImageCount = getMinImageCount . fSwapchainResources + getImageCount = getImageCount . fSwapchainResources + {-# INLINE getSurfaceExtent #-} + {-# INLINE getSurfaceFormat #-} + {-# INLINE getDepthFormat #-} + {-# INLINE getMultisample #-} + {-# INLINE getAnisotropy #-} + {-# INLINE getSwapchainViews #-} + {-# INLINE getMinImageCount #-} + {-# INLINE getImageCount #-} + type GPUWork = ( "host semaphore" ::: Vk.Semaphore , "frame index" ::: Word64 @@ -184,3 +209,8 @@ liftResourceT rt = asks (snd . fResources . snd) >>= liftIO . ResourceT.runInternalState rt + +type HKD :: (Type -> Type) -> Type -> Type +type family HKD f a where + HKD Identity a = a + HKD f a = f a diff --git a/src/Engine/Types/Options.hs b/src/Engine/Types/Options.hs --- a/src/Engine/Types/Options.hs +++ b/src/Engine/Types/Options.hs @@ -7,6 +7,8 @@ import RIO import Options.Applicative.Simple qualified as Opt +import Vulkan.Core10 qualified as Vk +import Vulkan.Extensions.VK_KHR_surface qualified as Khr import Paths_keid_core qualified @@ -14,6 +16,8 @@ data Options = Options { optionsVerbose :: Bool , optionsMaxFPS :: Maybe Int + , optionsPresent :: Maybe Khr.PresentModeKHR + , optionsMsaa :: Vk.SampleCountFlagBits , optionsFullscreen :: Bool , optionsDisplay :: Natural , optionsSize :: Maybe (Int, Int) @@ -51,6 +55,17 @@ , Opt.metavar "FPS" ] + optionsPresent <- Opt.optional . Opt.option readPresent $ mconcat + [ Opt.long "present" + , Opt.help "Presentation mode" + ] + + optionsMsaa <- Opt.option readMsaa $ mconcat + [ Opt.long "msaa" + , Opt.help "MSAA level" + , Opt.value Vk.SAMPLE_COUNT_4_BIT + ] + optionsFullscreen <- Opt.switch $ mconcat [ Opt.long "fullscreen" , Opt.short 'f' @@ -76,10 +91,65 @@ pure Options{..} +readPresent :: Opt.ReadM Khr.PresentModeKHR +readPresent = named <|> integral <|> Opt.readerError oops + where + named = do + o <- Opt.str + case lookup o presentModes of + Just found -> + pure found + Nothing -> + Opt.readerError $ "unexpected mode name: " <> show o + + integral = + fmap Khr.PresentModeKHR Opt.auto + + oops = unlines + [ "Available present modes (or use a number): " + , show $ map fst presentModes + ] + +presentModes :: [(Text, Khr.PresentModeKHR)] +presentModes = + [ ("immediate", Khr.PRESENT_MODE_IMMEDIATE_KHR) + , ("mailbox", Khr.PRESENT_MODE_MAILBOX_KHR) + , ("fifo", Khr.PRESENT_MODE_FIFO_KHR) + , ("fifo_relaxed", Khr.PRESENT_MODE_FIFO_RELAXED_KHR) + , ("shared_demand_refresh", Khr.PRESENT_MODE_SHARED_DEMAND_REFRESH_KHR) + , ("shared_continuous_refresh", Khr.PRESENT_MODE_SHARED_CONTINUOUS_REFRESH_KHR) + ] + +readMsaa :: Opt.ReadM Vk.SampleCountFlagBits +readMsaa = do + samples <- Opt.auto + case lookup samples msaaSamples of + Just found -> + pure found + Nothing -> + Opt.readerError $ mconcat + [ "Unexpected MSAA sample count: " + , show samples + , " (must be a power of 2 in [1..64] range)" + ] + +msaaSamples :: [(Int, Vk.SampleCountFlagBits)] +msaaSamples = + [ ( 1, Vk.SAMPLE_COUNT_1_BIT) + , ( 2, Vk.SAMPLE_COUNT_2_BIT) + , ( 4, Vk.SAMPLE_COUNT_4_BIT) + , ( 8, Vk.SAMPLE_COUNT_8_BIT) + , ( 16, Vk.SAMPLE_COUNT_16_BIT) + , ( 32, Vk.SAMPLE_COUNT_32_BIT) + , ( 64, Vk.SAMPLE_COUNT_64_BIT) + ] + readSize :: Opt.ReadM (Int, Int) readSize = do o <- Opt.str - let (w,h) = break (== 'x') o + let (w, h) = break (== 'x') o case (readMaybe w, readMaybe (drop 1 h)) of - (Just w', Just h') -> pure (w', h') - _ -> fail "Can't read window size" + (Just w', Just h') -> + pure (w', h') + _ -> + fail "Can't read window size" diff --git a/src/Engine/Types/RefCounted.hs b/src/Engine/Types/RefCounted.hs --- a/src/Engine/Types/RefCounted.hs +++ b/src/Engine/Types/RefCounted.hs @@ -4,7 +4,8 @@ import Control.Monad.Trans.Resource (allocate_) import GHC.IO.Exception (IOErrorType(UserError), IOException(IOError)) -import UnliftIO.Resource (MonadResource) +import UnliftIO.Resource (MonadResource, ReleaseKey) +import UnliftIO.Resource qualified as Resource -- | A 'RefCounted' will perform the specified action when the count reaches 0 data RefCounted = RefCounted @@ -48,3 +49,9 @@ resourceTRefCount :: MonadResource f => RefCounted -> f () resourceTRefCount r = void $ allocate_ (takeRefCounted r) (releaseRefCounted r) + +wrapped :: MonadResource m => m (ReleaseKey, a) -> m (RefCounted, a) +wrapped action = do + (key, res) <- action + rc <- newRefCounted $ Resource.release key + pure (rc, res) diff --git a/src/Engine/UI/Layout.hs b/src/Engine/UI/Layout.hs --- a/src/Engine/UI/Layout.hs +++ b/src/Engine/UI/Layout.hs @@ -42,6 +42,8 @@ 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 (App) +import UnliftIO.Resource (MonadResource) import Vulkan.Core10 qualified as Vk import Vulkan.NamedType ((:::)) @@ -94,7 +96,12 @@ type BoxProcess = Worker.Merge Box -trackScreen :: Engine.StageRIO st BoxProcess +trackScreen + :: ( MonadReader (App Engine.GlobalHandles st) m + , MonadResource m + , MonadUnliftIO m + ) + => m BoxProcess trackScreen = do screen <- Engine.askScreenVar Worker.spawnMerge1 mkBox screen @@ -105,7 +112,8 @@ } padAbs - :: ( MonadUnliftIO m + :: ( MonadResource m + , MonadUnliftIO m , Worker.HasOutput parent , Worker.GetOutput parent ~ Box , Worker.HasOutput padding @@ -130,7 +138,8 @@ dh = min h (top + bottom) padRel - :: ( MonadUnliftIO m + :: ( MonadResource m + , MonadUnliftIO m , Worker.HasOutput parent , Worker.GetOutput parent ~ Box , Worker.HasOutput padding @@ -147,7 +156,8 @@ boxPadAbs box (pad * vec4 h w h w) fitPlaceAbs - :: ( MonadUnliftIO m + :: ( MonadResource m + , MonadUnliftIO m , Worker.HasOutput parent , Worker.GetOutput parent ~ Box ) @@ -210,7 +220,8 @@ aspect = w / h splitsRelStatic - :: ( MonadUnliftIO m + :: ( MonadResource m + , MonadUnliftIO m , Worker.HasOutput parent , Worker.GetOutput parent ~ Box , Traversable t -- XXX: nested traversables may behave suprisingly @@ -243,7 +254,8 @@ ) hSplitRel - :: ( MonadUnliftIO m + :: ( MonadResource m + , MonadUnliftIO m , Worker.HasOutput parent , Worker.GetOutput parent ~ Box , Worker.HasOutput proportion @@ -274,6 +286,7 @@ vSplitRel :: ( MonadUnliftIO m + , MonadResource m , Worker.HasOutput parent , Worker.GetOutput parent ~ Box , Worker.HasOutput proportion diff --git a/src/Engine/Vulkan/Format.hs b/src/Engine/Vulkan/Format.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Vulkan/Format.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Engine.Vulkan.Format + ( HasVkFormat(..) + , genericVkFormat + + , formatSize + ) where + +import RIO +import GHC.Generics +import Geomancy + +import Data.Kind (Constraint, Type) +import Geomancy.IVec3 qualified as IVec3 +import Geomancy.UVec3 qualified as UVec3 +import Geomancy.Vec3 qualified as Vec3 +import Vulkan.Core10 qualified as Vk + +class HasVkFormat a where + getVkFormat :: [Vk.Format] + + default getVkFormat + :: GVkFormat (Rep a) + => [Vk.Format] + getVkFormat = genericVkFormat @a + +instance HasVkFormat () where + getVkFormat = [] + +instance HasVkFormat Float where + getVkFormat = [Vk.FORMAT_R32_SFLOAT] + +instance HasVkFormat Vec2 where + getVkFormat = [Vk.FORMAT_R32G32_SFLOAT] + +instance HasVkFormat Vec3 where + getVkFormat = [Vk.FORMAT_R32G32B32A32_SFLOAT] + +instance HasVkFormat Vec3.Packed where + getVkFormat = [Vk.FORMAT_R32G32B32_SFLOAT] + +instance HasVkFormat Vec4 where + getVkFormat = [Vk.FORMAT_R32G32B32A32_SFLOAT] + +instance HasVkFormat Quaternion where + getVkFormat = [Vk.FORMAT_R32G32B32A32_SFLOAT] + +instance HasVkFormat Mat4 where + getVkFormat = + [ Vk.FORMAT_R32G32B32A32_SFLOAT + , Vk.FORMAT_R32G32B32A32_SFLOAT + , Vk.FORMAT_R32G32B32A32_SFLOAT + , Vk.FORMAT_R32G32B32A32_SFLOAT + ] + +instance HasVkFormat Transform where + getVkFormat = getVkFormat @Mat4 + +instance HasVkFormat Int32 where + getVkFormat = [Vk.FORMAT_R32_SINT] + +instance HasVkFormat IVec2 where + getVkFormat = [Vk.FORMAT_R32G32_SINT] + +instance HasVkFormat IVec3 where + getVkFormat = [Vk.FORMAT_R32G32B32_SINT] + +instance HasVkFormat IVec3.Packed where + getVkFormat = [Vk.FORMAT_R32G32B32_SINT] + +instance HasVkFormat IVec4 where + getVkFormat = [Vk.FORMAT_R32G32B32A32_SINT] + +instance HasVkFormat Word32 where + getVkFormat = [Vk.FORMAT_R32_UINT] + +instance HasVkFormat UVec2 where + getVkFormat = [Vk.FORMAT_R32G32_UINT] + +instance HasVkFormat UVec3 where + getVkFormat = [Vk.FORMAT_R32G32B32A32_UINT] + +instance HasVkFormat UVec3.Packed where + getVkFormat = [Vk.FORMAT_R32G32B32_UINT] + +instance HasVkFormat UVec4 where + getVkFormat = [Vk.FORMAT_R32G32B32A32_UINT] + +instance HasVkFormat v => HasVkFormat (Point v) where + getVkFormat = getVkFormat @v + +genericVkFormat + :: forall a + . GVkFormat (Rep a) + => [Vk.Format] +genericVkFormat = gVkFormat (Proxy @(Rep a)) + +type GVkFormat :: (Type -> Type) -> Constraint +class GVkFormat f where + gVkFormat :: proxy f -> [Vk.Format] + +instance GVkFormat f => GVkFormat (M1 c cb f) where + gVkFormat _m1 = gVkFormat (Proxy @f) + +instance (GVkFormat l, GVkFormat r) => GVkFormat (l :*: r) where + gVkFormat _lr = gVkFormat (Proxy @l) <> gVkFormat (Proxy @r) + +instance HasVkFormat a => GVkFormat (K1 r a) where + gVkFormat _k1 = getVkFormat @a + +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/Pipeline.hs b/src/Engine/Vulkan/Pipeline.hs --- a/src/Engine/Vulkan/Pipeline.hs +++ b/src/Engine/Vulkan/Pipeline.hs @@ -1,6 +1,6 @@ module Engine.Vulkan.Pipeline ( Pipeline(..) - , destroy + , allocateWith , Specialization ) where @@ -9,9 +9,11 @@ import Data.Kind (Type) import Data.Tagged (Tagged(..)) import Data.Vector qualified as Vector +import GHC.Stack (withFrozenCallStack) +import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk -import Engine.Vulkan.Types (HasVulkan(..), DsLayouts) +import Engine.Vulkan.Types (DsLayouts, MonadVulkan, getDevice) data Pipeline (dsl :: [Type]) vertices instances = Pipeline { pipeline :: Vk.Pipeline @@ -19,19 +21,29 @@ , pDescLayouts :: Tagged dsl DsLayouts } -destroy - :: ( MonadIO io - , HasVulkan ctx +allocateWith + :: ( MonadVulkan env m + , Resource.MonadResource m ) - => ctx + => m (Pipeline dsl vertices instances) + -> m (Resource.ReleaseKey, Pipeline dsl vertices instances) +allocateWith action = withFrozenCallStack do + res <- action + device <- asks getDevice + key <- Resource.register $ + destroy device res + pure (key, res) + +destroy + :: MonadIO io + => Vk.Device -> Pipeline dsl vertices instances -> io () -destroy context Pipeline{..} = do +destroy device Pipeline{..} = do + -- FIXME: leave layout alone 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 type family Specialization pipeline diff --git a/src/Engine/Vulkan/Pipeline/Compute.hs b/src/Engine/Vulkan/Pipeline/Compute.hs --- a/src/Engine/Vulkan/Pipeline/Compute.hs +++ b/src/Engine/Vulkan/Pipeline/Compute.hs @@ -17,7 +17,6 @@ , Pipeline(..) , allocate , create - , destroy , bind , Compute @@ -26,31 +25,30 @@ import RIO import Data.Kind (Type) -import Data.List qualified as List import Data.Tagged (Tagged(..)) import Data.Vector qualified as Vector import GHC.Generics (Generic1) -import GHC.Stack (callStack, getCallStack, srcLocModule, withFrozenCallStack) +import GHC.Stack (withFrozenCallStack) 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.Utils.Debug qualified as Debug +import Vulkan.CStruct.Extends (SomeStruct(..)) import Vulkan.Zero (Zero(..)) import Engine.SpirV.Reflect (Reflect) import Engine.Vulkan.DescSets (Bound(..), Compatible) -import Engine.Vulkan.Pipeline (Pipeline(..), destroy) +import Engine.Vulkan.Pipeline (Pipeline(..)) +import Engine.Vulkan.Pipeline qualified as Pipeline import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) import Engine.Vulkan.Shader qualified as Shader -import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, DsBindings, getPipelineCache) +import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, DsLayoutBindings, getPipelineCache) import Render.Code (Code) import Resource.Collection (Generically1(..)) +import Resource.Vulkan.DescriptorLayout qualified as Layout +import Resource.Vulkan.Named qualified as Named data Config (dsl :: [Type]) spec = Config { cComputeCode :: ByteString - , cDescLayouts :: Tagged dsl [DsBindings] + , cDescLayouts :: Tagged dsl [DsLayoutBindings] , cPushConstantRanges :: Vector Vk.PushConstantRange , cSpecialization :: spec } @@ -87,66 +85,46 @@ ) => Config dsl spec -> m (ReleaseKey, Pipeline dsl Compute Compute) -allocate config = withFrozenCallStack do - ctx <- ask - Resource.allocate - (create ctx config) - (destroy ctx) +allocate config = + withFrozenCallStack $ + Pipeline.allocateWith $ create config create - :: ( HasVulkan ctx - , MonadUnliftIO m + :: ( MonadVulkan env io , Shader.Specialization spec + , HasCallStack ) - => ctx - -> Config dsl spec - -> m (Pipeline dsl Compute Compute) -create context Config{..} = do - -- XXX: copypasta from Pipeline.create - let - originModule = - fromString . List.intercalate "|" $ - map (srcLocModule . snd) (getCallStack callStack) - - 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 - Debug.nameObject device layout originModule + => Config dsl spec + -> io (Pipeline dsl Compute Compute) +create Config{..} = withFrozenCallStack do + -- TODO: get from outside ? + dsLayouts <- Layout.create $ Vector.fromList (unTagged cDescLayouts) - -- Compute stuff begins... + -- TODO: get from outside ?? + pipelineLayout <- Layout.forPipeline + dsLayouts + cPushConstantRanges + Named.objectOrigin pipelineLayout shader <- Shader.withSpecialization cSpecialization $ - Shader.create context Stages + Shader.create Stages { comp = Just cComputeCode } let cis = Vector.singleton . SomeStruct $ - pipelineCI (Shader.sPipelineStages shader) layout + pipelineCI (Shader.sPipelineStages shader) pipelineLayout + device <- asks getDevice Vk.createComputePipelines device cache cis Nothing >>= \case (Vk.SUCCESS, pipelines) -> case pipelines of - [one] -> do - Shader.destroy context shader - Debug.nameObject device one originModule + [pipeline] -> do + Shader.destroy shader + Named.objectOrigin pipeline pure Pipeline - { pipeline = one - , pLayout = Tagged layout + { pipeline = pipeline + , pLayout = Tagged pipelineLayout , pDescLayouts = Tagged dsLayouts } _ -> @@ -155,14 +133,7 @@ throwString $ "createComputePipelines: " <> show err where - device = getDevice context - cache = getPipelineCache context - - layoutCI dsLayouts = Vk.PipelineLayoutCreateInfo - { flags = zero - , setLayouts = dsLayouts - , pushConstantRanges = cPushConstantRanges - } + cache = getPipelineCache undefined pipelineCI stages layout = zero { Vk.layout = layout diff --git a/src/Engine/Vulkan/Pipeline/External.hs b/src/Engine/Vulkan/Pipeline/External.hs --- a/src/Engine/Vulkan/Pipeline/External.hs +++ b/src/Engine/Vulkan/Pipeline/External.hs @@ -28,15 +28,17 @@ import RIO -import Control.Monad.Trans.Resource (ReleaseKey, ResourceT, release) +import Control.Monad.Trans.Resource (ResourceT) import Data.List (maximum) import Data.Tagged (Tagged(..)) import RIO.ByteString qualified as ByteString import RIO.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist) +import RIO.FilePath ((), (<.>)) import RIO.Map qualified as Map import RIO.Text qualified as Text import RIO.Time (UTCTime, getCurrentTime) -import RIO.FilePath ((), (<.>)) +import UnliftIO.Resource (MonadResource, ReleaseKey) +import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk import Render.Code (Code(..)) @@ -47,16 +49,17 @@ import Engine.Vulkan.Pipeline.Graphics qualified as Graphics import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) import Engine.Vulkan.Shader qualified as Shader -import Engine.Vulkan.Types (DsBindings, HasRenderPass) +import Engine.Vulkan.Types (DsLayoutBindings, HasRenderPass) import Engine.Worker qualified as Worker type Process config = Worker.Timed () config spawn :: ( Foldable stages - , MonadUnliftIO m , MonadReader env m , HasLogFunc env + , MonadResource m + , MonadUnliftIO m ) => (stages (Maybe FilePath) -> m stuff) -> Text @@ -95,7 +98,8 @@ ) spawnReflect - :: ( MonadUnliftIO m + :: ( MonadResource m + , MonadUnliftIO m , MonadReader env m , HasLogFunc env , StageInfo stages @@ -149,7 +153,7 @@ reflDS <- Reflect.stagesBindMap stageRefl - reflIS <- Reflect.stagesInterfaceMap stageRefl + let reflIS = Reflect.stagesInterfaceMap stageRefl case Reflect.interfaceCompatible reflIS of Right ok -> logDebug $ displayShow ok @@ -221,14 +225,14 @@ ) => renderpass -> Vk.SampleCountFlagBits - -> Tagged dsl [DsBindings] + -> Tagged dsl [DsLayoutBindings] -> output -> Worker.ObserverIO (ReleaseKey, pipeline) -> StageFrameRIO rp p fr rs () observeGraphics rp msaa sceneBinds configP output = void $! Worker.observeIO configP output \(oldKey, _old) config -> do logDebug "Rebuilding pipeline" - release oldKey + Resource.release oldKey mapRIO fst $ Graphics.allocate Nothing msaa @@ -258,14 +262,14 @@ , config ~ Compute.Configure pipeline spec , pipeline ~ Compute.Pipeline dsl Compute Compute ) - => Tagged dsl [DsBindings] + => Tagged dsl [DsLayoutBindings] -> output -> Worker.ObserverIO (ReleaseKey, pipeline) -> StageFrameRIO rp p fr rs () observeCompute binds configP output = void $! Worker.observeIO configP output \(oldKey, _old) config -> do logDebug "Rebuilding pipeline" - release oldKey + Resource.release oldKey mapRIO fst $ Compute.allocate config { Compute.cDescLayouts = binds } @@ -297,7 +301,7 @@ ) => renderpass -> Vk.SampleCountFlagBits - -> Tagged dsl DsBindings + -> Tagged dsl DsLayoutBindings -> pf ConfigureGraphics -> pf Observers -> (forall a . pf a -> a ^ p) diff --git a/src/Engine/Vulkan/Pipeline/Graphics.hs b/src/Engine/Vulkan/Pipeline/Graphics.hs --- a/src/Engine/Vulkan/Pipeline/Graphics.hs +++ b/src/Engine/Vulkan/Pipeline/Graphics.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE UndecidableInstances #-} @@ -27,38 +28,42 @@ , Pipeline(..) , allocate , create - , Pipeline.destroy , bind + + , HasVertexInputBindings(..) + , vertexFormat + , instanceFormat ) where import RIO +import GHC.Generics import Data.Bits ((.|.)) import Data.Kind (Type) import Data.List qualified as List import Data.Tagged (Tagged(..)) import Data.Vector qualified as Vector -import GHC.Generics (Generic1) -import GHC.Stack (callStack, getCallStack, srcLocModule, withFrozenCallStack) +import Geomancy (Transform) +import GHC.Stack (withFrozenCallStack) 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.CStruct.Extends (SomeStruct(..)) import Vulkan.NamedType ((:::)) -import Vulkan.Utils.Debug qualified as Debug import Vulkan.Zero (Zero(..)) import Engine.SpirV.Reflect (Reflect) import Engine.Vulkan.DescSets (Bound(..), Compatible) +import Engine.Vulkan.Format (HasVkFormat(..), formatSize) import Engine.Vulkan.Pipeline (Pipeline(..)) import Engine.Vulkan.Pipeline qualified as Pipeline import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) import Engine.Vulkan.Shader qualified as Shader -import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), MonadVulkan, DsBindings, getPipelineCache) +import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), MonadVulkan, DsLayoutBindings, getPipelineCache) import Render.Code (Code) import Resource.Collection (Generically1(..)) +import Resource.Vulkan.DescriptorLayout qualified as Layout +import Resource.Vulkan.Named qualified as Named data Stages a = Stages { vert :: a -- ^ vertex @@ -119,7 +124,7 @@ { cStages :: StageSpirv , cReflect :: Maybe StageReflect , cVertexInput :: SomeStruct Vk.PipelineVertexInputStateCreateInfo - , cDescLayouts :: Tagged dsl [DsBindings] + , cDescLayouts :: Tagged dsl [DsLayoutBindings] , cPushConstantRanges :: Vector Vk.PushConstantRange , cBlend :: Bool , cDepthWrite :: Bool @@ -175,66 +180,48 @@ -> Config dsl vertices instances spec -> renderpass -> m (ReleaseKey, pipeline) -allocate extent msaa config renderpass = withFrozenCallStack do - ctx <- ask - Resource.allocate - (create ctx extent msaa renderpass config) - (Pipeline.destroy ctx) +allocate extent msaa config renderpass = + withFrozenCallStack $ + Pipeline.allocateWith $ create extent msaa renderpass config create - :: ( MonadUnliftIO io - , HasVulkan ctx + :: ( MonadVulkan env io , HasRenderPass renderpass , Shader.Specialization spec , HasCallStack ) - => ctx - -> Maybe Vk.Extent2D + => Maybe Vk.Extent2D -> Vk.SampleCountFlagBits -> renderpass -> Config dsl vertices instances spec -> io (Pipeline dsl vertices instances) -create context mextent msaa renderpass Config{..} = do - let - originModule = - fromString . List.intercalate "|" $ - map (srcLocModule . snd) (getCallStack callStack) - - 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 - +create mextent msaa renderpass Config{..} = withFrozenCallStack do -- TODO: get from outside - layout <- Vk.createPipelineLayout device (layoutCI dsLayouts) Nothing - Debug.nameObject device layout originModule + dsLayouts <- Layout.create $ Vector.fromList (unTagged cDescLayouts) + -- TODO: get from outside ? + pipelineLayout <- Layout.forPipeline + dsLayouts + cPushConstantRanges + Named.objectOrigin pipelineLayout + shader <- Shader.withSpecialization cSpecialization $ - Shader.create context cStages + Shader.create cStages let cis = Vector.singleton . SomeStruct $ - pipelineCI (Shader.sPipelineStages shader) layout + pipelineCI (Shader.sPipelineStages shader) pipelineLayout + device <- asks getDevice Vk.createGraphicsPipelines device cache cis Nothing >>= \case (Vk.SUCCESS, pipelines) -> case Vector.toList pipelines of - [one] -> do - Shader.destroy context shader - Debug.nameObject device one originModule + [pipeline] -> do + Shader.destroy shader + Named.objectOrigin pipeline pure Pipeline - { pipeline = one - , pLayout = Tagged layout + { pipeline = pipeline + , pLayout = Tagged pipelineLayout , pDescLayouts = Tagged dsLayouts } _ -> @@ -242,14 +229,7 @@ (err, _) -> error $ "createGraphicsPipelines: " <> show err where - device = getDevice context - cache = getPipelineCache context - - layoutCI dsLayouts = Vk.PipelineLayoutCreateInfo - { flags = zero - , setLayouts = dsLayouts - , pushConstantRanges = cPushConstantRanges - } + cache = getPipelineCache undefined pipelineCI stages layout = zero { Vk.stages = stages @@ -385,8 +365,14 @@ Bound $ Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_GRAPHICS pipeline Bound attrAction -vertexInput :: [(Vk.VertexInputRate, [Vk.Format])] -> SomeStruct Vk.PipelineVertexInputStateCreateInfo -vertexInput bindings = SomeStruct zero +vertexInput + :: forall a pipeLayout vertices instances + . ( a ~ Pipeline pipeLayout vertices instances + , HasVertexInputBindings vertices -- XXX: 0-2 of {positions, attrs} (e.g. position + uv) + , HasVertexInputBindings instances -- XXX: 0+ of instance attrs (e.g. static params + dynamic transforms) + ) + => SomeStruct Vk.PipelineVertexInputStateCreateInfo +vertexInput = SomeStruct zero { Vk.vertexBindingDescriptions = binds , Vk.vertexAttributeDescriptions = attrs } @@ -401,6 +387,11 @@ attrs = attrBindings $ map snd bindings + bindings = + filter (not . null . snd) $ + vertexInputBindings @vertices <> + vertexInputBindings @instances + -- * Utils attrBindings :: [[Vk.Format]] -> Vector Vk.VertexInputAttributeDescription @@ -426,22 +417,19 @@ , 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 +type VertexInputBinding = (Vk.VertexInputRate, [Vk.Format]) - Vk.FORMAT_R32G32B32A32_UINT -> 16 - Vk.FORMAT_R32G32B32_UINT -> 12 - Vk.FORMAT_R32G32_UINT -> 8 - Vk.FORMAT_R32_UINT -> 4 +vertexFormat :: forall a . HasVkFormat a => VertexInputBinding +vertexFormat = (Vk.VERTEX_INPUT_RATE_VERTEX, getVkFormat @a) - Vk.FORMAT_R32G32B32A32_SINT -> 16 - Vk.FORMAT_R32G32B32_SINT -> 12 - Vk.FORMAT_R32G32_SINT -> 8 - Vk.FORMAT_R32_SINT -> 4 +instanceFormat :: forall a . HasVkFormat a => VertexInputBinding +instanceFormat = (Vk.VERTEX_INPUT_RATE_INSTANCE, getVkFormat @a) - format -> - error $ "Format size unknown: " <> show format +class HasVertexInputBindings a where + vertexInputBindings :: [VertexInputBinding] + +instance HasVertexInputBindings () where + vertexInputBindings = [] + +instance HasVertexInputBindings Transform where + vertexInputBindings = [instanceFormat @Transform] diff --git a/src/Engine/Vulkan/Shader.hs b/src/Engine/Vulkan/Shader.hs --- a/src/Engine/Vulkan/Shader.hs +++ b/src/Engine/Vulkan/Shader.hs @@ -18,13 +18,15 @@ import Data.Vector qualified as Vector import Data.Vector.Storable qualified as Storable import Foreign qualified +import GHC.Stack (withFrozenCallStack) import Vulkan.Core10 qualified as Vk import Vulkan.CStruct.Extends (SomeStruct(..)) import Vulkan.Zero (Zero(..)) import Unsafe.Coerce (unsafeCoerce) import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) -import Engine.Vulkan.Types (HasVulkan(..)) +import Engine.Vulkan.Types (MonadVulkan, getDevice) +import Resource.Vulkan.Named qualified as Named data Shader = Shader { sModules :: Vector Vk.ShaderModule @@ -32,23 +34,25 @@ } create - :: ( MonadIO io - , HasVulkan ctx + :: ( MonadVulkan env io , StageInfo t + , HasCallStack ) - => ctx - -> t (Maybe ByteString) + => t (Maybe ByteString) -> Maybe Vk.SpecializationInfo -> io Shader -create context stages spec = do +create stages spec = withFrozenCallStack do + device <- asks getDevice staged <- Vector.forM collected \(stage, code) -> do module_ <- Vk.createShaderModule - (getDevice context) + device zero { Vk.code = code } Nothing + Named.objectOrigin module_ + pure ( module_ , SomeStruct zero @@ -68,10 +72,11 @@ (stage, Just code) <- toList $ (,) <$> stageFlagBits <*> stages pure (stage, code) -destroy :: (MonadIO io, HasVulkan ctx) => ctx -> Shader -> io () -destroy context Shader{sModules} = +destroy :: MonadVulkan env io => Shader -> io () +destroy Shader{sModules} = do + device <- asks getDevice Vector.forM_ sModules \module_ -> - Vk.destroyShaderModule (getDevice context) module_ Nothing + Vk.destroyShaderModule device module_ Nothing -- * Specialization constants diff --git a/src/Engine/Vulkan/Swapchain.hs b/src/Engine/Vulkan/Swapchain.hs --- a/src/Engine/Vulkan/Swapchain.hs +++ b/src/Engine/Vulkan/Swapchain.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} module Engine.Vulkan.Swapchain ( SwapchainResources(..) @@ -70,7 +71,9 @@ , HasVulkan env , HasLogFunc env ) - => Khr.SwapchainKHR + => Maybe Khr.PresentModeKHR + -> Vk.SampleCountFlagBits + -> Khr.SwapchainKHR -- ^ Previous swapchain, can be NULL_HANDLE -> Vk.Extent2D -- ^ If the swapchain size determines the surface size, use this size @@ -78,11 +81,11 @@ -> Worker.Var Vk.Extent2D -> RIO env SwapchainResources -- -> ResourceT (RIO env) SwapchainResources -allocSwapchainResources oldSwapchain windowSize surface screenVar = do +allocSwapchainResources present msaa oldSwapchain windowSize surface screenVar = do logDebug "Allocating swapchain resources" device <- asks getDevice - info@SwapchainInfo{..} <- createSwapchain oldSwapchain windowSize surface + info@SwapchainInfo{..} <- createSwapchain present msaa oldSwapchain windowSize surface -- XXX: Get all the swapchain images, and create views for them (_, swapchainImages) <- Khr.getSwapchainImagesKHR device siSwapchain @@ -112,12 +115,16 @@ , HasVulkan env , HasLogFunc env ) - => Vk.Extent2D + => Maybe Khr.PresentModeKHR + -> Vk.SampleCountFlagBits + -> Vk.Extent2D -> SwapchainResources -- ^ The reference to these resources will be dropped -> RIO env SwapchainResources -recreateSwapchainResources windowSize oldResources = do +recreateSwapchainResources present msaa windowSize oldResources = do sr <- allocSwapchainResources + present + msaa (siSwapchain $ srInfo oldResources) windowSize (siSurface $ srInfo oldResources) @@ -131,13 +138,15 @@ , MonadVulkan env m , HasLogFunc env ) - => Khr.SwapchainKHR + => Maybe Khr.PresentModeKHR + -> Vk.SampleCountFlagBits + -> 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 +createSwapchain present msaa oldSwapchain explicitSize surf = do physical <- asks getPhysicalDevice device <- asks getDevice props <- asks $ pdiProperties . getPhysicalDeviceInfo @@ -152,8 +161,15 @@ throwString $ "Surface images do not support " <> show flag -- Select a present mode + desiredPresentModes <- case present of + Nothing -> do + logDebug $ "Using default present modes: " <> displayShow defaultPresentModes + pure defaultPresentModes + Just selected -> do + logDebug $ "Forcing selected present mode: " <> displayShow selected + pure [selected] (_, availablePresentModes) <- Khr.getPhysicalDeviceSurfacePresentModesKHR physical surf - presentMode <- + presentMode <- case filter (`V.elem` availablePresentModes) desiredPresentModes of [] -> do logError "Unable to find a suitable present mode for swapchain" @@ -184,14 +200,14 @@ let minImageCount = let - limit = case Khr.maxImageCount (surfaceCaps :: Khr.SurfaceCapabilitiesKHR) of + limit = case surfaceCaps.maxImageCount 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) + buffer + surfaceCaps.minImageCount in min limit desired @@ -232,7 +248,7 @@ , siSurfaceFormat = surfaceFormat , siSurfaceColorspace = surfaceColorspace , siDepthFormat = depthFormat - , siMultisample = msaaSamples props + , siMultisample = msaaSamples msaa props , siAnisotropy = Vk.maxSamplerAnisotropy (Vk.limits props) , siImageExtent = imageExtent } @@ -295,10 +311,14 @@ , Vk.FORMAT_D32_SFLOAT ] -msaaSamples :: Vk.PhysicalDeviceProperties -> Vk.SampleCountFlagBits -msaaSamples Vk.PhysicalDeviceProperties{limits} = +msaaSamples + :: Vk.SampleCountFlagBits + -> Vk.PhysicalDeviceProperties + -> Vk.SampleCountFlagBits +msaaSamples upperLimit Vk.PhysicalDeviceProperties{limits} = case samplesAvailable of [] -> + -- XXX: Something went wrong... Vk.SAMPLE_COUNT_1_BIT best : _rest -> best @@ -309,27 +329,26 @@ samplesAvailable = do countBit <- msaaCandidates - guard $ (counts .&. countBit) /= zeroBits + guard $ countBit <= upperLimit -- XXX: requested + guard $ (counts .&. countBit) /= zeroBits -- XXX: capable 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_64_BIT -- XXX: extremely unrealistic? + , Vk.SAMPLE_COUNT_32_BIT -- XXX: unrealistic? + , Vk.SAMPLE_COUNT_16_BIT -- XXX: possible, but not that impactful + , Vk.SAMPLE_COUNT_8_BIT + , Vk.SAMPLE_COUNT_4_BIT -- XXX: Khronos-recommended for rasterizing , Vk.SAMPLE_COUNT_2_BIT + , Vk.SAMPLE_COUNT_1_BIT -- XXX: i.e. "disable", always available ] -- | An ordered list of the present mode to be chosen for the swapchain. -desiredPresentModes :: [Khr.PresentModeKHR] -desiredPresentModes = +defaultPresentModes :: [Khr.PresentModeKHR] +defaultPresentModes = [ 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. @@ -402,8 +421,14 @@ Vk.Extent2D{width, height} = extent Vk.Rect2D{offset, extent} = viewrect -setDynamicFullscreen :: MonadIO io => Vk.CommandBuffer -> SwapchainResources -> io () -setDynamicFullscreen cb sr = do +setDynamicFullscreen + :: ( HasSwapchain swapchain + , MonadIO io + ) + => Vk.CommandBuffer + -> swapchain + -> io () +setDynamicFullscreen cb swapchain = do Vk.cmdSetViewport cb 0 [ Vk.Viewport @@ -417,11 +442,10 @@ ] Vk.cmdSetScissor cb 0 [ Vk.Rect2D - { offset = Vk.Offset2D 0 0 - , extent = siImageExtent + { offset = zero + , extent = extent } ] where - SwapchainResources{srInfo} = sr - SwapchainInfo{siImageExtent} = srInfo - Vk.Extent2D{width, height} = siImageExtent + extent@Vk.Extent2D{width, height} = + getSurfaceExtent swapchain diff --git a/src/Engine/Vulkan/Types.hs b/src/Engine/Vulkan/Types.hs --- a/src/Engine/Vulkan/Types.hs +++ b/src/Engine/Vulkan/Types.hs @@ -11,7 +11,7 @@ , Queues(..) , DsLayouts - , DsBindings + , DsLayoutBindings , Bound(..) ) where @@ -20,6 +20,7 @@ import Data.Kind (Type) import RIO.App (App(..)) +import RIO.State (MonadState(..)) import UnliftIO.Resource (MonadResource) import Vulkan.Core10 qualified as Vk import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12 @@ -115,8 +116,10 @@ => a -> RIO env () -type DsBindings = [(Vk.DescriptorSetLayoutBinding, Vk12.DescriptorBindingFlags)] +type DsLayoutBindings = [(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) + deriving stock (Foldable, Traversable, Functor) + deriving newtype (Applicative, Monad, MonadIO, MonadUnliftIO) + deriving newtype (MonadReader r, MonadState s) diff --git a/src/Engine/Window/CursorPos.hs b/src/Engine/Window/CursorPos.hs --- a/src/Engine/Window/CursorPos.hs +++ b/src/Engine/Window/CursorPos.hs @@ -16,11 +16,15 @@ import UnliftIO.Resource (ReleaseKey) import UnliftIO.Resource qualified as Resource -import Engine.Types (GlobalHandles(..), StageRIO) +import Engine.Types (ghWindow) +import Engine.Events.Sink (MonadSink) -type Callback st = Double -> Double -> StageRIO st () +type Callback m = Double -> Double -> m () -callback :: Callback st -> StageRIO st ReleaseKey +callback + :: MonadSink rs m + => Callback m + -> m ReleaseKey callback handler = do window <- asks $ ghWindow . appEnv withUnliftIO \ul -> @@ -28,7 +32,7 @@ Resource.register $ GLFW.setCursorPosCallback window Nothing -mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.CursorPosCallback +mkCallback :: UnliftIO m -> Callback m -> 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 --- a/src/Engine/Window/Drop.hs +++ b/src/Engine/Window/Drop.hs @@ -12,11 +12,12 @@ import UnliftIO.Resource (ReleaseKey) import UnliftIO.Resource qualified as Resource -import Engine.Types (GlobalHandles(..), StageRIO) +import Engine.Events.Sink (MonadSink) +import Engine.Types (GlobalHandles(..)) -type Callback st = [FilePath] -> StageRIO st () +type Callback m = [FilePath] -> m () -callback :: Callback st -> StageRIO st ReleaseKey +callback :: MonadSink rs m => Callback m -> m ReleaseKey callback handler = do window <- asks $ ghWindow . appEnv withUnliftIO \ul -> @@ -24,7 +25,7 @@ Resource.register $ GLFW.setDropCallback window Nothing -mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.DropCallback +mkCallback :: UnliftIO m -> Callback m -> 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 --- a/src/Engine/Window/Key.hs +++ b/src/Engine/Window/Key.hs @@ -16,11 +16,12 @@ import UnliftIO.Resource (ReleaseKey) import UnliftIO.Resource qualified as Resource -import Engine.Types (GlobalHandles(..), StageRIO) +import Engine.Events.Sink (MonadSink) +import Engine.Types (ghWindow) -type Callback st = Int -> (GLFW.ModifierKeys, GLFW.KeyState, GLFW.Key) -> StageRIO st () +type Callback m = Int -> (GLFW.ModifierKeys, GLFW.KeyState, GLFW.Key) -> m () -callback :: Callback st -> StageRIO st ReleaseKey +callback :: MonadSink rs m => Callback m -> m ReleaseKey callback handler = do window <- asks $ ghWindow . appEnv withUnliftIO \ul -> @@ -28,7 +29,7 @@ Resource.register $ GLFW.setKeyCallback window Nothing -mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.KeyCallback +mkCallback :: UnliftIO m -> Callback m -> 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 --- a/src/Engine/Window/MouseButton.hs +++ b/src/Engine/Window/MouseButton.hs @@ -20,16 +20,20 @@ import RIO import Graphics.UI.GLFW qualified as GLFW +import Resource.Collection (Generic1, Generically1(..)) import RIO.App (appEnv) import UnliftIO.Resource (ReleaseKey) import UnliftIO.Resource qualified as Resource -import Resource.Collection (Generic1, Generically1(..)) -import Engine.Types (GlobalHandles(..), StageRIO) +import Engine.Events.Sink (MonadSink) +import Engine.Types (GlobalHandles(..)) -type Callback st = (GLFW.ModifierKeys, GLFW.MouseButtonState, GLFW.MouseButton) -> StageRIO st () +type Callback m = (GLFW.ModifierKeys, GLFW.MouseButtonState, GLFW.MouseButton) -> m () -callback :: Callback st -> StageRIO st ReleaseKey +callback + :: MonadSink rs m + => Callback m + -> m ReleaseKey callback handler = do window <- asks $ ghWindow . appEnv withUnliftIO \ul -> @@ -37,7 +41,7 @@ Resource.register $ GLFW.setMouseButtonCallback window Nothing -mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.MouseButtonCallback +mkCallback :: UnliftIO m -> Callback m -> 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 --- a/src/Engine/Window/Scroll.hs +++ b/src/Engine/Window/Scroll.hs @@ -12,11 +12,15 @@ import UnliftIO.Resource (ReleaseKey) import UnliftIO.Resource qualified as Resource -import Engine.Types (GlobalHandles(..), StageRIO) +import Engine.Events.Sink (MonadSink) +import Engine.Types (GlobalHandles(..)) -type Callback st = Double -> Double -> StageRIO st () +type Callback m = Double -> Double -> m () -callback :: Callback st -> StageRIO st ReleaseKey +callback + :: MonadSink rs m + => Callback m + -> m ReleaseKey callback handler = do window <- asks $ ghWindow . appEnv withUnliftIO \ul -> @@ -24,7 +28,7 @@ Resource.register $ GLFW.setScrollCallback window Nothing -mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.ScrollCallback +mkCallback :: UnliftIO m -> Callback m -> 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 --- a/src/Engine/Worker.hs +++ b/src/Engine/Worker.hs @@ -50,12 +50,6 @@ , newSource , pubSource , subSource - - , HasWorker(..) - , register - , registerCollection - , registered - , registeredCollection ) where import RIO @@ -286,7 +280,9 @@ type Cell input output = (Var input, Merge output) spawnCell - :: MonadUnliftIO m + :: ( MonadUnliftIO m + , MonadResource m + ) => (input -> output) -> input -> m (Cell input output) @@ -298,6 +294,7 @@ -- | Timer-driven stateful producer. data Timed config output = Timed { tWorker :: ThreadId + , tKey :: Resource.ReleaseKey , tActive :: TVar Bool , tConfig :: TVar config , tOutput :: Var output @@ -312,7 +309,9 @@ getOutput = tOutput spawnTimed_ - :: MonadUnliftIO m + :: ( MonadUnliftIO m + , MonadResource m + ) => Bool -> Int -> output @@ -330,7 +329,9 @@ () spawnTimed - :: MonadUnliftIO m + :: ( MonadUnliftIO m + , MonadResource m + ) => Bool -> Either Int (config -> Int) -> (config -> m (output, state)) @@ -344,6 +345,7 @@ tOutput <- newVar initialOutput tWorker <- forkIO $ step tActive tConfig tOutput initialState + tKey <- Resource.register $ killThread tWorker pure Timed{..} where step activeVar configVar output curState = do @@ -365,8 +367,9 @@ -- | Supply-driven step cell. data Merge o = Merge - { mWorker :: ThreadId - , mOutput :: TVar (Versioned o) + { mWorker :: ThreadId + , mKey :: Resource.ReleaseKey + , mOutput :: TVar (Versioned o) } instance HasOutput (Merge o) where @@ -375,6 +378,7 @@ spawnMerge1 :: ( MonadUnliftIO m + , MonadResource m , HasOutput i ) => (GetOutput i -> o) @@ -402,13 +406,17 @@ else retrySTM + key <- Resource.register $ killThread worker + pure Merge { mWorker = worker + , mKey = key , mOutput = output } spawnMerge2 :: ( MonadUnliftIO m + , MonadResource m , HasOutput i1 , HasOutput i2 ) @@ -443,8 +451,11 @@ else retrySTM + key <- Resource.register $ killThread worker + pure Merge { mWorker = worker + , mKey = key , mOutput = output } where @@ -452,6 +463,7 @@ spawnMerge3 :: ( MonadUnliftIO m + , MonadResource m , HasOutput i1 , HasOutput i2 , HasOutput i3 @@ -490,8 +502,11 @@ else retrySTM + key <- Resource.register $ killThread worker + pure Merge { mWorker = worker + , mKey = key , mOutput = output } where @@ -499,6 +514,7 @@ spawnMerge4 :: ( MonadUnliftIO m + , MonadResource m , HasOutput i1 , HasOutput i2 , HasOutput i3 @@ -541,8 +557,11 @@ else retrySTM + key <- Resource.register $ killThread worker + pure Merge { mWorker = worker + , mKey = key , mOutput = output } where @@ -557,6 +576,7 @@ :: ( Traversable t , HasOutput input , MonadUnliftIO m + , MonadResource m ) => (t (GetOutput input) -> output) -> t input @@ -585,8 +605,11 @@ else retrySTM + key <- Resource.register $ killThread worker + pure Merge { mWorker = worker + , mKey = key , mOutput = output } @@ -644,56 +667,3 @@ 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 = mWorker . snd - -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 --- a/src/Render/Code.hs +++ b/src/Render/Code.hs @@ -7,6 +7,7 @@ , compileVert , compileFrag , compileComp + , targetEnv ) where import RIO @@ -24,10 +25,13 @@ show = Text.unpack . unCode compileVert :: Code -> Q Exp -compileVert = compileShaderQ Nothing "vert" Nothing . Text.unpack . unCode +compileVert = compileShaderQ (Just targetEnv) "vert" Nothing . Text.unpack . unCode compileFrag :: Code -> Q Exp -compileFrag = compileShaderQ Nothing "frag" Nothing . Text.unpack . unCode +compileFrag = compileShaderQ (Just targetEnv) "frag" Nothing . Text.unpack . unCode compileComp :: Code -> Q Exp -compileComp = compileShaderQ Nothing "comp" Nothing . Text.unpack . unCode +compileComp = compileShaderQ (Just targetEnv) "comp" Nothing . Text.unpack . unCode + +targetEnv :: IsString a => a +targetEnv = "vulkan1.2" diff --git a/src/Render/Draw.hs b/src/Render/Draw.hs --- a/src/Render/Draw.hs +++ b/src/Render/Draw.hs @@ -54,7 +54,7 @@ => Vk.CommandBuffer -> Model.Indexed storage pos attrs -> instances - -> Bound dsl attrs (Model.VertexBuffersOf instances) m () + -> Bound dsl (Model.Vertex pos attrs) (Model.VertexBuffersOf instances) m () indexed cmd model instances = indexedRanges cmd model instances [wholeIndexed] where wholeIndexed = Model.IndexRange @@ -73,10 +73,10 @@ -> Model.Indexed storage pos attrs -> instances -> [Model.IndexRange] - -> Bound dsl attrs (Model.VertexBuffersOf instances) m () + -> Bound dsl (Model.Vertex pos attrs) (Model.VertexBuffersOf instances) m () indexedRanges cmd model instances ranges = do - checkedTanges <- traverse check ranges - Bound $ unsafeIndexedRanges True cmd model instances checkedTanges + checkedRanges <- traverse check ranges + Bound $ unsafeIndexedRanges True cmd model instances checkedRanges where check ir@Model.IndexRange{..} | irFirstIndex > maxIndex = @@ -101,7 +101,7 @@ -> instances -> Int -> t Model.IndexRange - -> Bound dsl attrs (Model.VertexBuffersOf instances) m () + -> Bound dsl (Model.Vertex pos attrs) (Model.VertexBuffersOf instances) m () indexedParts drawAttrs cmd model instances startInstance parts = Bound $ unsafeIndexedParts drawAttrs cmd model instances startInstance parts @@ -113,7 +113,7 @@ => Vk.CommandBuffer -> Model.Indexed storage pos unusedAttrs -> instances - -> Bound dsl ignoreAttrs (Model.VertexBuffersOf instances) m () + -> Bound dsl (Model.Vertex pos ignoreAttrs) (Model.VertexBuffersOf instances) m () indexedPos cmd model instances = indexedPosRanges cmd model instances [wholeIndexed] where wholeIndexed = Model.IndexRange @@ -128,10 +128,10 @@ -> Model.Indexed storage pos unusedAttrs -> instances -> [Model.IndexRange] - -> Bound dsl ignoreAttrs (Model.VertexBuffersOf instances) m () + -> Bound dsl (Model.Vertex pos ignoreAttrs) (Model.VertexBuffersOf instances) m () indexedPosRanges cmd model instances ranges = do - checkedTanges <- traverse check ranges - Bound $ unsafeIndexedRanges False cmd model instances checkedTanges + checkedRanges <- traverse check ranges + Bound $ unsafeIndexedRanges False cmd model instances checkedRanges where check ir@Model.IndexRange{..} | irFirstIndex > maxIndex = diff --git a/src/Render/Pass/Offscreen.hs b/src/Render/Pass/Offscreen.hs --- a/src/Render/Pass/Offscreen.hs +++ b/src/Render/Pass/Offscreen.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedRecordDot #-} module Render.Pass.Offscreen ( Settings(..) @@ -12,6 +13,7 @@ import RIO +import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Resource qualified as Resource import Data.Bits ((.|.)) import Data.Vector qualified as Vector @@ -21,11 +23,14 @@ import Vulkan.Utils.Debug qualified as Debug import Vulkan.Zero (zero) -import Engine.Types.RefCounted (RefCounted, newRefCounted, resourceTRefCount) +import Engine.Types.RefCounted (RefCounted) +import Engine.Types.RefCounted qualified as RefCounted import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), RenderPass(..), MonadVulkan) import Resource.Image (AllocatedImage) import Resource.Image qualified as Image +import Resource.Region qualified as Region import Resource.Texture (CubeMap, Flat, Texture(..)) +import Resource.Vulkan.Named qualified as Named {- XXX: Consider spec wrt. parameters and intended use! @@ -35,7 +40,9 @@ { sLabel :: Text , sExtent :: Vk.Extent2D , sFormat :: Vk.Format + , sColorLayout :: Maybe Vk.ImageLayout -- ^ Target color format when used for export. , sDepthFormat :: Vk.Format + , sDepthLayout :: Maybe Vk.ImageLayout -- ^ Target depth format when used for export. , sLayers :: Word32 , sMultiView :: Bool -- ^ Makes sense only for multiple layers. , sSamples :: Vk.SampleCountFlagBits -- ^ Multisample prevents mipmapping and cubes. @@ -64,11 +71,11 @@ getRenderArea = oRenderArea instance RenderPass Offscreen where - refcountRenderpass = resourceTRefCount . oRelease + refcountRenderpass = RefCounted.resourceTRefCount . oRelease colorTexture :: Offscreen -> Texture Flat colorTexture Offscreen{..} = Texture - { tFormat = Image.aiFormat oColor + { tFormat = oColor.aiFormat , tMipLevels = oMipLevels , tLayers = oLayers , tAllocatedImage = oColor @@ -76,7 +83,7 @@ colorCube :: Offscreen -> Texture CubeMap colorCube Offscreen{..} = Texture - { tFormat = Image.aiFormat oColor + { tFormat = oColor.aiFormat , tMipLevels = oMipLevels , tLayers = oLayers -- TODO: get from type param , tAllocatedImage = oColor @@ -84,7 +91,7 @@ depthTexture :: Offscreen -> Texture Flat depthTexture Offscreen{..} = Texture - { tFormat = Image.aiFormat oDepth + { tFormat = oDepth.aiFormat , tMipLevels = oMipLevels , tLayers = oLayers , tAllocatedImage = oDepth @@ -92,7 +99,7 @@ depthCube :: Offscreen -> Texture CubeMap depthCube Offscreen{..} = Texture - { tFormat = Image.aiFormat oDepth + { tFormat = oDepth.aiFormat , tMipLevels = oMipLevels , tLayers = oLayers -- TODO: get from type param , tAllocatedImage = oDepth @@ -106,11 +113,14 @@ => Settings -> m Offscreen allocate settings@Settings{..} = do - logDebug $ "Allocating Offscreen resources for " <> display sLabel - - (_rpKey, renderPass) <- allocateRenderPass settings + (_passKey, renderPass) <- allocateRenderPass settings - (refcounted, color, depth, framebuffer) <- allocateFramebuffer settings renderPass + (release, resources) <- RefCounted.wrapped $ Region.run do + Region.logDebug + ("Allocating Offscreen resources for " <> display sLabel) + ("Releasing Offscreen resources for " <> display sLabel) + allocateFramebuffer settings renderPass + let (color, depth, framebuffer) = resources pure Offscreen { oRenderPass = renderPass @@ -122,7 +132,7 @@ , oColor = color , oDepth = depth , oFrameBuffer = framebuffer - , oRelease = refcounted + , oRelease = release } where fullSurface = Vk.Rect2D @@ -174,7 +184,7 @@ { Vk.format = sFormat settings , Vk.samples = sSamples settings , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED - , Vk.finalLayout = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL + , Vk.finalLayout = fromMaybe Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL (sColorLayout settings) , Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_STORE , Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE @@ -185,7 +195,7 @@ { Vk.format = sDepthFormat settings , Vk.samples = sSamples settings , Vk.initialLayout = Vk.IMAGE_LAYOUT_UNDEFINED - , Vk.finalLayout = Vk.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL + , Vk.finalLayout = fromMaybe Vk.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL (sDepthLayout settings) , Vk.loadOp = Vk.ATTACHMENT_LOAD_OP_CLEAR , Vk.storeOp = Vk.ATTACHMENT_STORE_OP_DONT_CARE , Vk.stencilLoadOp = Vk.ATTACHMENT_LOAD_OP_DONT_CARE @@ -246,8 +256,7 @@ -- ** Framebuffer type FramebufferOffscreen = - ( RefCounted - , Image.AllocatedImage + ( Image.AllocatedImage , Image.AllocatedImage , Vk.Framebuffer ) @@ -259,44 +268,36 @@ ) => Settings -> Vk.RenderPass - -> m FramebufferOffscreen + -> ResourceT m FramebufferOffscreen allocateFramebuffer Settings{..} renderPass = do - context <- ask - let device = getDevice context - let - Vk.Extent2D{width, height} = sExtent - mipLevels = extentMips sExtent + Region.logDebug + ("Allocating Offscreen resources for " <> display sLabel) + ("Releasing Offscreen resources for " <> display sLabel) - (colorKey, color) <- Resource.allocate - ( Image.create - context - (Just $ sLabel <> ".color") - Vk.IMAGE_ASPECT_COLOR_BIT - sExtent - (if sMipMap then mipLevels else 1) - sLayers - sSamples - sFormat - ( Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT .|. - Vk.IMAGE_USAGE_SAMPLED_BIT .|. - Vk.IMAGE_USAGE_TRANSFER_SRC_BIT - ) + color <- Image.allocate + (Just $ sLabel <> ".color") + Vk.IMAGE_ASPECT_COLOR_BIT + (Image.inflateExtent sExtent 1) + (if sMipMap then mipLevels else 1) + sLayers + sSamples + sFormat + ( Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT .|. + Vk.IMAGE_USAGE_SAMPLED_BIT .|. + Vk.IMAGE_USAGE_TRANSFER_SRC_BIT ) - (Image.destroy context) - (depthKey, depth) <- Resource.allocate - ( Image.create - context - (Just $ sLabel <> ".depth") - Vk.IMAGE_ASPECT_DEPTH_BIT - sExtent - (if sMipMap then mipLevels else 1) - sLayers - sSamples - sDepthFormat - (Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT .|. Vk.IMAGE_USAGE_SAMPLED_BIT) + depth <- Image.allocate + (Just $ sLabel <> ".depth") + Vk.IMAGE_ASPECT_DEPTH_BIT + (Image.inflateExtent sExtent 1) + (if sMipMap then mipLevels else 1) + sLayers + sSamples + sDepthFormat + ( Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT .|. + Vk.IMAGE_USAGE_SAMPLED_BIT ) - (Image.destroy context) let attachments = Vector.fromList @@ -323,17 +324,15 @@ , Vk.layers = fbNumLayers } - (framebufferKey, framebuffer) <- Vk.withFramebuffer device fbCI Nothing Resource.allocate - Debug.nameObject device framebuffer $ encodeUtf8 sLabel <> ".FB" - - releaseDebug <- toIO $ logDebug "Releasing Offscreen resources" - release <- newRefCounted do - releaseDebug - Resource.release colorKey - Resource.release depthKey - Resource.release framebufferKey + device <- asks getDevice + framebuffer <- Vk.createFramebuffer device fbCI Nothing + void $! Resource.register $ Vk.destroyFramebuffer device framebuffer Nothing + Named.object framebuffer $ sLabel <> ".FB" - pure (release, color, depth, framebuffer) + pure (color, depth, framebuffer) + where + Vk.Extent2D{width, height} = sExtent + mipLevels = extentMips sExtent extentMips :: Num t => Vk.Extent2D -> t extentMips Vk.Extent2D{width, height} = go 1 (min width height) diff --git a/src/Render/Samplers.hs b/src/Render/Samplers.hs --- a/src/Render/Samplers.hs +++ b/src/Render/Samplers.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE DeriveAnyClass #-} - module Render.Samplers ( Collection(..) , allocate + , allocateFrom , indices , Params , params - , create - , destroy + + , createInfo ) where import RIO +import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Resource qualified as Resource import GHC.Generics (Generic1) import Vulkan.Core10 qualified as Vk @@ -20,8 +20,9 @@ import Vulkan.Zero (zero) import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan) -import Resource.Collection qualified as Collection import Resource.Collection (Generically1(..)) +import Resource.Collection qualified as Collection +import Vulkan.CStruct.Extends (PokeChain, Extendss) data Collection a = Collection { linearMipRepeat :: a -- 0 @@ -54,44 +55,52 @@ indices = fmap fst $ Collection.enumerate params allocate - :: ( MonadVulkan env m - , Resource.MonadResource m - ) + :: MonadVulkan env io => "max anisotropy" ::: Float - -> m (Resource.ReleaseKey, Collection Vk.Sampler) -allocate maxAnisotropy = do - context <- ask - Resource.allocate - (for params $ create context maxAnisotropy) - (traverse_ $ destroy context) + -> ResourceT io (Collection Vk.Sampler) +allocate maxAnisotropy = + for params \p -> + allocateFrom maxAnisotropy p id -create - :: (MonadIO io, HasVulkan context) - => context - -> "max anisotropy" ::: Float +allocateFrom + :: ( PokeChain e + , Extendss Vk.SamplerCreateInfo e + , MonadVulkan env io + ) + => "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 - } + -> (Vk.SamplerCreateInfo '[] -> Vk.SamplerCreateInfo e) + -> ResourceT io Vk.Sampler +allocateFrom maxAnisotropy (filt, mips, reps) f = do + device <- asks getDevice + sampler <- Vk.createSampler + device + (f $ createInfo maxAnisotropy filt mips reps) + Nothing + _key <- Resource.register $ + Vk.destroySampler device sampler Nothing + pure sampler -destroy :: (MonadIO io, HasVulkan context) => context -> Vk.Sampler -> io () -destroy context sampler = - Vk.destroySampler (getDevice context) sampler Nothing +createInfo + :: "max anisotropy" ::: Float + -> Vk.Filter + -> "max LoD" ::: Float + -> Vk.SamplerAddressMode + -> Vk.SamplerCreateInfo '[] +createInfo maxAnisotropy filt mips reps = 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 + } diff --git a/src/Resource/Buffer.hs b/src/Resource/Buffer.hs --- a/src/Resource/Buffer.hs +++ b/src/Resource/Buffer.hs @@ -6,16 +6,17 @@ import Data.Vector.Storable qualified as VectorS import Foreign (Storable) import Foreign qualified +import UnliftIO.Resource (MonadResource) 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.Types (StageRIO) -import Engine.Vulkan.Types (HasVulkan(getAllocator), Queues(qTransfer)) +import Engine.Vulkan.Types (HasVulkan(getAllocator), Queues(qTransfer), MonadVulkan) import Engine.Worker qualified as Worker import Resource.CommandBuffer (oneshot_) +import Resource.Vulkan.Named qualified as Named data Store = Staged | Coherent @@ -26,31 +27,47 @@ , aCapacity :: Int , aUsed :: Word32 , aUsage :: Vk.BufferUsageFlagBits + , aLabel :: Maybe Text } deriving (Show) +instance Vk.HasObjectType (Allocated s a) where + objectTypeAndHandle = + Vk.objectTypeAndHandle . aBuffer + allocateCoherent - :: (Resource.MonadResource m, Storable a, HasVulkan context) - => context + :: ( MonadVulkan env m + , Resource.MonadResource m + , Storable a + ) + => Maybe Text -> 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) +allocateCoherent label usage initialSize xs = do + res <- createCoherent label usage initialSize xs + destroyIO <- toIO do + context <- ask + destroy context res + key <- Resource.register destroyIO + pure (key, res) createCoherent - :: forall a context io . (Storable a, HasVulkan context, MonadUnliftIO io) - => context + :: forall a env m + . ( MonadVulkan env m + , Storable a + ) + => Maybe Text -> 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 + -> m (Allocated 'Coherent a) +createCoherent aLabel usage initialSize xs = do + allocator <- asks getAllocator + (aBuffer, aAllocation, aAllocationInfo) <- VMA.createBuffer allocator bci aci + traverse_ (Named.object aBuffer) aLabel - when (len /= 0) $ + when (len > 0) $ if VMA.mappedData aAllocationInfo == Foreign.nullPtr then error "TODO: recover from unmapped data and flush manually" else @@ -64,7 +81,6 @@ , .. } where - len = VectorS.length xs lenBytes = Foreign.sizeOf (undefined :: a) * len @@ -88,34 +104,39 @@ } createStaged - :: forall a context io . (Storable a, HasVulkan context, MonadUnliftIO io) - => context + :: forall a env m + . ( Storable a + , MonadVulkan env m + ) + => Maybe Text -> 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 + -> m (Allocated 'Staged a) +createStaged aLabel commandQueues usage initialSize xs = do + allocator <- asks getAllocator + (aBuffer, aAllocation, aAllocationInfo) <- VMA.createBuffer allocator bci aci + traverse_ (Named.object aBuffer) aLabel - when (len /= 0) . liftIO $ - VMA.withBuffer vma stageCI stageAI bracket \(staging, _stage, stageInfo) -> + when (len > 0) $ + VMA.withBuffer allocator 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 -> + liftIO $ VectorS.unsafeWith xs \src -> Foreign.copyBytes (Foreign.castPtr $ VMA.mappedData stageInfo) src lenBytes + context <- ask copyBuffer_ context commandQueues aBuffer staging (fromIntegral sizeBytes) pure Allocated { aCapacity = max initialSize len , aUsed = fromIntegral len , aUsage = usage + , aLabel = Nothing , .. } where - vma = getAllocator context - len = VectorS.length xs lenBytes = Foreign.sizeOf (undefined :: a) * len @@ -144,6 +165,16 @@ , VMA.requiredFlags = Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT } +register + :: ( MonadVulkan env m + , MonadResource m + ) + => Allocated stage a + -> m Resource.ReleaseKey +register Allocated{aBuffer, aAllocation} = do + allocator <- asks getAllocator + Resource.register $ VMA.destroyBuffer allocator aBuffer aAllocation + destroy :: (MonadUnliftIO io, HasVulkan context) => context @@ -152,16 +183,13 @@ 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 + :: ( MonadIO m + , Storable a + ) + => Word32 + -> Allocated 'Coherent a + -> m (Maybe a) peekCoherent ix Allocated{..} = case VMA.mappedData aAllocationInfo of _ | ix + 1 > aUsed -> @@ -172,8 +200,32 @@ liftIO . fmap Just $ Foreign.peekElemOff (Foreign.castPtr ptr) (fromIntegral ix) +{-# INLINE pokeCoherent #-} +pokeCoherent + :: ( MonadVulkan env m + , Storable a + ) + => Allocated 'Coherent a + -> Word32 + -> a + -> m () +pokeCoherent Allocated{..} ix new = + case VMA.mappedData aAllocationInfo of + _ | ix + 1 > aUsed -> + pure () + ptr | ptr == Foreign.nullPtr -> + pure () + ptr -> + liftIO $ + Foreign.pokeElemOff + (Foreign.castPtr ptr) + (fromIntegral ix) + new + updateCoherent - :: (Foreign.Storable a, MonadUnliftIO io) + :: ( MonadUnliftIO io + , Foreign.Storable a + ) => VectorS.Vector a -> Allocated 'Coherent a -> io (Allocated 'Coherent a) @@ -188,25 +240,30 @@ len = VectorS.length xs lenBytes = len * Foreign.sizeOf (VectorS.head xs) +{-# INLINE updateCoherentResize_ #-} updateCoherentResize_ - :: (Storable a, HasVulkan context, MonadUnliftIO io) - => context - -> Allocated 'Coherent a + :: ( MonadVulkan env m + , Storable a + ) + => Allocated 'Coherent a -> VectorS.Vector a - -> io (Allocated 'Coherent a) -updateCoherentResize_ ctx old xs = + -> m (Allocated 'Coherent a) +updateCoherentResize_ old xs = if newSize <= oldSize then updateCoherent xs old else do - destroyAll ctx [old] - createCoherent ctx (aUsage old) newSize xs + ctx <- ask + destroy ctx old + createCoherent (aLabel old) (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) + :: ( MonadUnliftIO io + , HasVulkan context + ) => context -> Queues Vk.CommandPool -> ("dstBuffer" ::: Vk.Buffer) @@ -221,16 +278,19 @@ type ObserverCoherent a = Worker.ObserverIO (Allocated 'Coherent a) newObserverCoherent - :: Storable a - => Vk.BufferUsageFlagBits + :: ( MonadVulkan env m + , Storable a + ) + => "label" ::: Text + -> Vk.BufferUsageFlagBits -> Int - -> Resource.ResourceT (StageRIO st) (ObserverCoherent a) -newObserverCoherent usage initialSize = do - context <- ask - - initialBuffer <- createCoherent context usage initialSize mempty + -> VectorS.Vector a + -> Resource.ResourceT m (ObserverCoherent a) +newObserverCoherent label usage initialCapacity initialData = do + initialBuffer <- createCoherent (Just label) usage initialCapacity initialData observer <- Worker.newObserverIO initialBuffer + context <- ask void $! Resource.register do currentBuffer <- Worker.readObservedIO observer destroy context currentBuffer @@ -239,15 +299,27 @@ {-# INLINE observeCoherentResize_ #-} observeCoherentResize_ - :: ( HasVulkan env + :: ( MonadVulkan env m , Worker.HasOutput source , Worker.GetOutput source ~ VectorS.Vector output , Storable output ) => source -> ObserverCoherent output - -> RIO env () + -> m () observeCoherentResize_ source observer = do - context <- ask - Worker.observeIO_ source observer $ - updateCoherentResize_ context + Worker.observeIO_ source observer updateCoherentResize_ + +{-# INLINE observeCoherentSingle #-} +observeCoherentSingle + :: ( MonadVulkan env m + , Worker.HasOutput source + , Worker.GetOutput source ~ output + , Storable output + ) + => source + -> ObserverCoherent output + -> m () +observeCoherentSingle source observer = + Worker.observeIO_ source observer \a b -> + pokeCoherent a 0 b $> a diff --git a/src/Resource/CommandBuffer.hs b/src/Resource/CommandBuffer.hs --- a/src/Resource/CommandBuffer.hs +++ b/src/Resource/CommandBuffer.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedRecordDot #-} + module Resource.CommandBuffer ( allocatePools , withPools @@ -10,6 +12,7 @@ import UnliftIO.Resource (MonadResource) import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk +import Vulkan.Core10.CommandBuffer qualified as CommandBuffer import Vulkan.CStruct.Extends (SomeStruct(..)) import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..)) import Vulkan.Zero (zero) @@ -55,9 +58,8 @@ 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 + { CommandBuffer.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT } Vk.useCommandBuffer buf oneTime $ action buf diff --git a/src/Resource/DescriptorSet.hs b/src/Resource/DescriptorSet.hs deleted file mode 100644 --- a/src/Resource/DescriptorSet.hs +++ /dev/null @@ -1,37 +0,0 @@ -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 --- a/src/Resource/Image.hs +++ b/src/Resource/Image.hs @@ -1,29 +1,43 @@ +{-# LANGUAGE OverloadedRecordDot #-} + module Resource.Image ( AllocatedImage(..) - , create - , destroy - , subresource + , allocate + , allocateView + + , DstImage + , allocateDst + , copyBufferToDst + , updateFromStorable + , transitionLayout , copyBufferToImage + + , subresource + , inflateExtent ) where import RIO import Data.Bits (shiftR, (.|.)) import RIO.Vector qualified as Vector +import RIO.Vector.Storable qualified as Storable +import UnliftIO.Resource (MonadResource) +import UnliftIO.Resource qualified as Resource 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(..), Queues(..)) +import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, Queues(..)) +import Resource.Buffer qualified as Buffer import Resource.CommandBuffer (oneshot_) +import Resource.Vulkan.Named qualified as Named data AllocatedImage = AllocatedImage { aiAllocation :: VMA.Allocation - , aiExtent :: Vk.Extent2D + , aiExtent :: Vk.Extent3D , aiFormat :: Vk.Format , aiImage :: Vk.Image , aiImageView :: Vk.ImageView @@ -31,38 +45,32 @@ } deriving (Show) -create - :: ( MonadIO io - , HasVulkan ctx +allocate + :: ( MonadVulkan env io + , MonadResource io ) - => ctx - -> Maybe Text + => Maybe Text -> Vk.ImageAspectFlags - -> "image dimensions" ::: Vk.Extent2D + -> "image dimensions" ::: Vk.Extent3D -> "mip levels" ::: Word32 -> "stored layers" ::: Word32 -> Vk.SampleCountFlagBits -> Vk.Format -> Vk.ImageUsageFlags -> io AllocatedImage -create context mlabel aspect extent mipLevels numLayers samples format usage = do - let - device = getDevice context - allocator = getAllocator context +allocate mlabel aspect extent mipLevels numLayers samples format usage = do + allocator <- asks getAllocator (image, allocation, _info) <- VMA.createImage allocator imageCI imageAllocationCI - for_ mlabel \label -> - Debug.nameObject device image $ encodeUtf8 label <> ".label" + void $! Resource.register $ + VMA.destroyImage allocator image allocation + traverse_ (Named.object image) mlabel - imageView <- Vk.createImageView - device - (imageViewCI image) - Nothing - for_ mlabel \label -> - Debug.nameObject device image $ encodeUtf8 label <> ".view" + imageView <- allocateView image format subr + traverse_ (Named.object imageView) $ fmap (<> ":view") mlabel pure AllocatedImage { aiAllocation = allocation @@ -73,13 +81,18 @@ , aiImageRange = subr } where - Vk.Extent2D{width, height} = extent + imageType = + case extent of + Vk.Extent3D{depth=1} -> + Vk.IMAGE_TYPE_2D + _ -> + Vk.IMAGE_TYPE_3D imageCI = zero - { Vk.imageType = Vk.IMAGE_TYPE_2D + { Vk.imageType = imageType , Vk.flags = createFlags , Vk.format = format - , Vk.extent = Vk.Extent3D width height 1 + , Vk.extent = extent , Vk.mipLevels = mipLevels , Vk.arrayLayers = numLayers , Vk.tiling = Vk.IMAGE_TILING_OPTIMAL @@ -94,45 +107,164 @@ , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT } - imageViewCI image = zero + createFlags = + case numLayers of + 6 -> + Vk.IMAGE_CREATE_CUBE_COMPATIBLE_BIT + _ -> + zero + + subr = subresource aspect mipLevels numLayers + +allocateView + :: ( MonadVulkan env m + , MonadResource m + ) + => Vk.Image + -> Vk.Format + -> Vk.ImageSubresourceRange + -> m Vk.ImageView +allocateView image format subr = do + device <- asks getDevice + imageView <- Vk.createImageView + device + imageViewCI + Nothing + void $! Resource.register $ Vk.destroyImageView device imageView Nothing + pure imageView + + where + imageViewCI = zero { Vk.image = image - , Vk.viewType = viewType + , Vk.viewType = guessViewType subr , Vk.format = format , Vk.components = zero , Vk.subresourceRange = subr } - (createFlags, viewType) = - case numLayers of - 1 -> - (zero, Vk.IMAGE_VIEW_TYPE_2D) - 6 -> - (Vk.IMAGE_CREATE_CUBE_COMPATIBLE_BIT, Vk.IMAGE_VIEW_TYPE_CUBE) - _ -> - (zero, Vk.IMAGE_VIEW_TYPE_2D_ARRAY) +-------------------------------------------- - subr = subresource aspect mipLevels numLayers +newtype DstImage = DstImage AllocatedImage -destroy - :: ( MonadIO io - , HasVulkan context +-- | Allocate an image and transition it into TRANSFER_DST_OPTIOMAL +allocateDst + :: ( MonadVulkan env m + , MonadResource m ) - => context + => Queues Vk.CommandPool + -> Maybe Text + -> ("image dimensions" ::: Vk.Extent3D) + -> ("mip levels" ::: Word32) + -> ("stored layers" ::: Word32) + -> Vk.Format + -> m DstImage +allocateDst pool name extent3d mipLevels numLayers format = do + ai <- allocate + name + Vk.IMAGE_ASPECT_COLOR_BIT + extent3d + mipLevels + numLayers + Vk.SAMPLE_COUNT_1_BIT + format + (Vk.IMAGE_USAGE_SAMPLED_BIT .|. Vk.IMAGE_USAGE_TRANSFER_DST_BIT) + + transitionLayout + pool + (aiImage ai) + mipLevels + numLayers -- XXX: arrayLayers is always 0 for now + format + Vk.IMAGE_LAYOUT_UNDEFINED + Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + + pure $ DstImage ai + +copyBufferToDst + :: ( MonadVulkan env m + , Integral deviceSize + , Foldable t + ) + => Queues Vk.CommandPool + -> Vk.Buffer + -> DstImage + -> "mip offsets" ::: t deviceSize + -> m AllocatedImage +copyBufferToDst pool source (DstImage ai) offsets = do + copyBufferToImage + pool + source + (aiImage ai) + (aiExtent ai) + offsets + layerCount + + transitionLayout + pool + (aiImage ai) + levelCount + layerCount -- XXX: arrayLayers is always 0 for now + (aiFormat ai) + Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL + + pure ai + where + Vk.ImageSubresourceRange{layerCount, levelCount} = aiImageRange ai + +{-# INLINE updateFromStorable #-} +updateFromStorable + :: ( Storable a + , MonadVulkan env m + , MonadResource m + ) + => Queues Vk.CommandPool -> AllocatedImage - -> io () -destroy context AllocatedImage{..} = do - -- traceM "destroyAllocatedImage" - Vk.destroyImageView (getDevice context) aiImageView Nothing - VMA.destroyImage (getAllocator context) aiImage aiAllocation + -> Storable.Vector a + -> m AllocatedImage +updateFromStorable pools ai update = do + (_transient, staging) <- + Buffer.allocateCoherent + (Just "updateFromStorable:staging") + Vk.BUFFER_USAGE_TRANSFER_SRC_BIT + 1 + update --------------------------------------------- + transitionLayout + pools + ai.aiImage + 1 + 1 + ai.aiFormat + Vk.IMAGE_LAYOUT_UNDEFINED + Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + copyBufferToImage + pools + staging.aBuffer + ai.aiImage + (Vk.Extent3D ai.aiExtent.width ai.aiExtent.height 1) + (Vector.singleton 0 :: Vector Word32) -- offsets + 1 + + transitionLayout + pools + ai.aiImage + 1 + 1 + ai.aiFormat + Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL + Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL + + -- logDebug "Updating map texture... done" + pure ai + +{-# INLINE transitionLayout #-} transitionLayout - :: ( HasVulkan context - , MonadUnliftIO m + :: ( MonadVulkan env m + -- , MonadUnliftIO m ) - => context - -> Queues Vk.CommandPool + => Queues Vk.CommandPool -> Vk.Image -> "mip levels" ::: Word32 -> "layer count" ::: Word32 @@ -140,7 +272,8 @@ -> "old" ::: Vk.ImageLayout -> "new" ::: Vk.ImageLayout -> m () -transitionLayout ctx pool image mipLevels layerCount format old new = +transitionLayout pool image mipLevels layerCount format old new = do + ctx <- ask case (old, new) of (Vk.IMAGE_LAYOUT_UNDEFINED, Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL) -> oneshot_ ctx pool qTransfer \buf -> @@ -207,56 +340,22 @@ , Vk.subresourceRange = subresource aspectMask mipLevels layerCount } --- imageBarrier cb oldLayout newLayout aspectMask srcStage srcMask dstStage dstMask image mipLevels layerCount = --- Vk.cmdPipelineBarrier --- cb --- srcStage --- dstStage --- zero --- mempty --- mempty --- (Vector.singleton barrier) --- where --- barrier = SomeStruct zero --- { Vk.srcAccessMask = srcMask --- , Vk.dstAccessMask = dstMask --- , Vk.oldLayout = oldLayout --- , Vk.newLayout = newLayout --- , 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 - } - +{-# INLINE copyBufferToImage #-} copyBufferToImage - :: ( HasVulkan context - , Foldable t + :: ( Foldable t , Integral deviceSize - , MonadUnliftIO m + , MonadVulkan env m ) - => context - -> Queues Vk.CommandPool + => Queues Vk.CommandPool -> Vk.Buffer -> Vk.Image -> "base extent" ::: Vk.Extent3D -> "mip offsets" ::: t deviceSize -> "layer count" ::: Word32 -> m () -copyBufferToImage ctx pool src dst Vk.Extent3D{..} mipOffsets layerCount = - oneshot_ ctx pool qTransfer \cmd -> +copyBufferToImage pools src dst Vk.Extent3D{..} mipOffsets layerCount = do + context <- ask + oneshot_ context pools qTransfer \cmd -> Vk.cmdCopyBufferToImage cmd src dst Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL $ Vector.fromList copyRegions where @@ -276,6 +375,35 @@ , Vk.imageExtent = Vk.Extent3D { width = max 1 $ width `shiftR` mipLevel , height = max 1 $ height `shiftR` mipLevel - , depth = depth + , depth = max 1 $ depth `shiftR` mipLevel } } + +-- * Helpers + +{-# INLINEABLE inflateExtent #-} +inflateExtent :: Vk.Extent2D -> Word32 -> Vk.Extent3D +inflateExtent Vk.Extent2D{..} depth = Vk.Extent3D{..} + +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 + } + +guessViewType :: Vk.ImageSubresourceRange -> Vk.ImageViewType +guessViewType Vk.ImageSubresourceRange{layerCount} = + case layerCount of + 1 -> + Vk.IMAGE_VIEW_TYPE_2D + 6 -> + Vk.IMAGE_VIEW_TYPE_CUBE + _ -> + Vk.IMAGE_VIEW_TYPE_2D_ARRAY diff --git a/src/Resource/Mesh/Codec.hs b/src/Resource/Mesh/Codec.hs --- a/src/Resource/Mesh/Codec.hs +++ b/src/Resource/Mesh/Codec.hs @@ -27,6 +27,7 @@ import Engine.Vulkan.Types (MonadVulkan, Queues) import Resource.Buffer qualified as Buffer import Resource.Model qualified as Model +import Resource.Region qualified as Region -- * Format meta @@ -181,18 +182,21 @@ -> FilePath -> m ( Resource.ReleaseKey - , (meta, Storable.Vector nodes, Model.Indexed 'Buffer.Staged Vec3.Packed attrs) + , ( 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)) + Region.run do + logDebug $ "Staging " <> fromString fp + indexed <- Model.createStaged (Just $ fromString fp) pools positions attrs indices + Model.registerIndexed_ indexed + pure (meta, nodes, indexed) loadBlobs :: forall attrs env nodes meta m diff --git a/src/Resource/Model.hs b/src/Resource/Model.hs --- a/src/Resource/Model.hs +++ b/src/Resource/Model.hs @@ -1,22 +1,36 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + module Resource.Model where import RIO +import GHC.Generics import Codec.Serialise qualified as CBOR +import Data.Kind (Constraint, Type) import Data.List qualified as List import Data.Vector.Storable qualified as Storable import Foreign (Storable(..)) +import Geomancy (Vec2) +import Geomancy.Vec3 qualified as Vec3 +import UnliftIO.Resource (MonadResource) import Vulkan.Core10 qualified as Vk -import Engine.Vulkan.Types (HasVulkan(..), Queues(..)) +import Engine.Vulkan.Pipeline.Graphics (HasVertexInputBindings(..)) +import Engine.Vulkan.Format (HasVkFormat(..)) +import Engine.Vulkan.Pipeline.Graphics qualified as Graphics +import Engine.Vulkan.Types (MonadVulkan, Queues(..)) import Resource.Buffer qualified as Buffer data Indexed storage pos attrs = Indexed - { iPositions :: Buffer.Allocated storage pos + { iLabel :: Maybe Text + , iPositions :: Buffer.Allocated storage pos , iAttrs :: Buffer.Allocated storage attrs , iIndices :: Buffer.Allocated storage Word32 } deriving (Show) +type Vertex2d attrs = Vertex Vec2 attrs +type Vertex3d attrs = Vertex Vec3.Packed attrs + data Vertex pos attrs = Vertex { vPosition :: pos , vAttrs :: attrs @@ -39,11 +53,37 @@ , vAttrs = inject pos } +instance + ( HasVkFormat pos + , HasVkFormat attrs + ) => + Graphics.HasVertexInputBindings (Vertex pos attrs) where + vertexInputBindings = + [ Graphics.vertexFormat @pos + , Graphics.vertexFormat @attrs + ] + class HasVertexBuffers a where type VertexBuffersOf a getVertexBuffers :: a -> [Vk.Buffer] getInstanceCount :: a -> Word32 + default getVertexBuffers + :: ( Generic a + , GHasVertexBuffers (Rep a) + ) + => a + -> [Vk.Buffer] + getVertexBuffers = genericGetVertexBuffers + + default getInstanceCount + :: ( Generic a + , GHasVertexBuffers (Rep a) + ) + => a + -> Word32 + getInstanceCount = genericGetInstanceCount + instance HasVertexBuffers () where type VertexBuffersOf () = () @@ -62,6 +102,39 @@ {-# INLINE getInstanceCount #-} getInstanceCount = Buffer.aUsed +genericGetVertexBuffers + :: ( Generic a + , GHasVertexBuffers (Rep a) + ) + => a + -> [Vk.Buffer] +genericGetVertexBuffers = gVertexBuffers . GHC.Generics.from + +genericGetInstanceCount + :: ( Generic a + , GHasVertexBuffers (Rep a) + ) + => a + -> Word32 +genericGetInstanceCount = gInstanceCount . GHC.Generics.from + +type GHasVertexBuffers :: (Type -> Type) -> Constraint +class GHasVertexBuffers f where + gVertexBuffers :: forall a . f a -> [Vk.Buffer] + gInstanceCount :: forall a . f a -> Word32 + +instance GHasVertexBuffers f => GHasVertexBuffers (M1 c cb f) where + gVertexBuffers (M1 f) = gVertexBuffers f + gInstanceCount (M1 f) = gInstanceCount f + +instance (GHasVertexBuffers l, GHasVertexBuffers r) => GHasVertexBuffers (l :*: r) where + gVertexBuffers (l :*: r) = gVertexBuffers l <> gVertexBuffers r + gInstanceCount (l :*: r) = min (gInstanceCount l) (gInstanceCount r) + +instance HasVertexBuffers a => GHasVertexBuffers (K1 r a) where + gVertexBuffers (K1 a) = getVertexBuffers a + gInstanceCount (K1 a) = getInstanceCount a + data IndexRange = IndexRange { irFirstIndex :: Word32 , irIndexCount :: Word32 @@ -85,13 +158,16 @@ pokeByteOff ptr 4 irIndexCount createStagedL - :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io) - => context + :: ( MonadVulkan env m + , Storable pos + , Storable attrs + ) + => Maybe Text -> 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 + -> m (Indexed 'Buffer.Staged pos attrs) +createStagedL label pool vertices mindices = createStaged label pool pv av iv where pv = Storable.fromList ps av = Storable.fromList as @@ -108,52 +184,72 @@ pure (vPosition, vAttrs) createStaged - :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io) - => context + :: ( MonadVulkan env m + , Storable pos + , Storable attrs + ) + => Maybe Text -> 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 + -> m (Indexed 'Buffer.Staged pos attrs) +createStaged label pool pv av iv = do + positions <- Buffer.createStaged (label <&> \m -> mappend m ".positions") pool Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT 0 pv + attrs <- Buffer.createStaged (label <&> \m -> mappend m ".attrs") pool Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT 0 av + indices <- Buffer.createStaged (label <&> \m -> mappend m ".indices") pool Vk.BUFFER_USAGE_INDEX_BUFFER_BIT 0 iv pure Indexed - { iPositions = positions + { iLabel = label + , iPositions = positions , iAttrs = attrs , iIndices = indices } createCoherentEmpty - :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io) - => context + :: ( MonadVulkan env m + , Storable pos + , Storable attrs + ) + => Maybe Text -> 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 + -> m (Indexed 'Buffer.Coherent pos attrs) +createCoherentEmpty label initialSize = Indexed label + <$> Buffer.createCoherent (label <&> \m -> mappend m ".positions") Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT initialSize mempty + <*> Buffer.createCoherent (label <&> \m -> mappend m ".attrs") Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT initialSize mempty + <*> Buffer.createCoherent (label <&> \m -> mappend m ".indices") Vk.BUFFER_USAGE_INDEX_BUFFER_BIT initialSize mempty +registerIndexed_ + :: ( MonadVulkan env m + , MonadResource m + ) + => Indexed storage pos attrs + -> m () +registerIndexed_ Indexed{..} = do + void $! Buffer.register iPositions + void $! Buffer.register iAttrs + void $! Buffer.register iIndices + 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] + :: MonadVulkan env m + => Indexed storage pos attrs + -> m () +destroyIndexed Indexed{..} = do + ctx <- ask + Buffer.destroy ctx iPositions + Buffer.destroy ctx iAttrs + Buffer.destroy ctx iIndices updateCoherent - :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io) - => context - -> [Vertex pos attrs] + :: ( MonadVulkan env m + , Storable pos + , Storable attrs + ) + => [Vertex pos attrs] -> Indexed 'Buffer.Coherent pos attrs - -> io (Indexed 'Buffer.Coherent pos attrs) -updateCoherent ctx vertices old = do + -> m (Indexed 'Buffer.Coherent pos attrs) +updateCoherent vertices old = do Indexed{..} <- pick - Indexed + Indexed iLabel <$> Buffer.updateCoherent pv iPositions <*> Buffer.updateCoherent av iAttrs <*> Buffer.updateCoherent iv iIndices @@ -162,8 +258,8 @@ if oldSize > newSize then pure old else do - destroyIndexed ctx old - createCoherentEmpty ctx (max newSize $ oldSize * 2) + destroyIndexed old + createCoherentEmpty (iLabel old) (max newSize $ oldSize * 2) oldSize = Buffer.aCapacity $ iIndices old newSize = Storable.length pv diff --git a/src/Resource/Model/Observer.hs b/src/Resource/Model/Observer.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Model/Observer.hs @@ -0,0 +1,211 @@ +{- | Experimental helpers for managing models with multiple instance buffers. + +Only works with fully-coherent models and atomic stores. +Not particularly efficient: when any element is changed, everything gets fully updated. +-} + +module Resource.Model.Observer + ( newCoherent + , observeCoherent + + , VertexBuffers(..) + , genericCreateInitial + , genericDestroyCurrent + + , UpdateCoherent(..) + , genericUpdateCoherent + ) where + +import RIO +import GHC.Generics + +import Control.Monad.Trans.Resource (ResourceT) +import Control.Monad.Trans.Resource qualified as Resource +import Data.Kind (Type) +import Data.Text qualified as Text +import Data.Vector.Storable qualified as Storable +import Vulkan.Core10 qualified as Vk + +import Engine.Types () +import Engine.Vulkan.Types (HasVulkan, MonadVulkan) +import Engine.Worker qualified as Worker +import Resource.Buffer qualified as Buffer + +newCoherent + :: ( VertexBuffers res + , MonadVulkan env m + ) + => Int + -> Text + -> ResourceT m (Worker.ObserverIO res) +newCoherent initialSize label = do + initial <- createInitial initialSize label + observer <- Worker.newObserverIO initial + + context <- ask + void $! Resource.register do + current <- Worker.readObservedIO observer + destroyCurrent context current + + pure observer + +observeCoherent + :: ( MonadVulkan env m + , Worker.HasOutput output + , UpdateCoherent bufs (Worker.GetOutput output) + ) + => output + -> Worker.ObserverIO bufs + -> m () +observeCoherent process observer = + void $ Worker.observeIO process observer updateCoherent + +class VertexBuffers a where + createInitial :: forall env m . MonadVulkan env m => Int -> Text -> ResourceT m a + + default createInitial + :: forall env m + . ( Generic a + , GVertexBuffers (Rep a) + , MonadVulkan env m + ) + => Int + -> Text + -> ResourceT m a + createInitial = genericCreateInitial + + destroyCurrent :: forall env . HasVulkan env => env -> a -> IO () + default destroyCurrent + :: forall env + . ( Generic a + , GVertexBuffers (Rep a) + , HasVulkan env + ) + => env + -> a + -> IO () + destroyCurrent = genericDestroyCurrent + +{- XXX: Terminal instance for generic observable requiring only MonadVulkan. + +Initial values can be written post-hoc using `updateCoherent` on observed data. +The more problematic part is using hardcoded usage argument. +This is fine for the main use case of model instance buffers, but makes it unsuitable for other uses. +-} +instance Storable a => VertexBuffers (Buffer.Allocated 'Buffer.Coherent a) where + createInitial initialCapacity label = + Buffer.createCoherent + (Just label) + Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT + initialCapacity + mempty + + destroyCurrent ctx buf = Buffer.destroy ctx buf + +genericCreateInitial + :: ( Generic a + , GVertexBuffers (Rep a) + , MonadVulkan env m + ) + => Int + -> Text + -> ResourceT m a +genericCreateInitial size label = + fmap GHC.Generics.to (gcreate size label) + +genericDestroyCurrent + :: ( Generic a + , GVertexBuffers (Rep a) + , HasVulkan env + ) + => env + -> a + -> IO () +genericDestroyCurrent env = gdestroy env . GHC.Generics.from + +class GVertexBuffers (f :: Type -> Type) where + gcreate :: forall env m a . MonadVulkan env m => Int -> Text -> ResourceT m (f a) + gdestroy :: forall env a . HasVulkan env => env -> f a -> IO () + +instance GVertexBuffers f => GVertexBuffers (D1 c f) where + gcreate size label = fmap M1 $ gcreate size label + gdestroy env (M1 a) = gdestroy env a + +instance GVertexBuffers f => GVertexBuffers (C1 c f) where + gcreate size label = fmap M1 $ gcreate size label + gdestroy env (M1 a) = gdestroy env a + +instance (GVertexBuffers l, GVertexBuffers r) => GVertexBuffers (l :*: r) where + gcreate size label = (:*:) + <$> gcreate size label + <*> gcreate size label + gdestroy env (l :*: r) = + gdestroy env r <> + gdestroy env l + +instance (GVertexBuffers f, Selector c) => GVertexBuffers (M1 S c f) where + gcreate size label = + fmap M1 $ + gcreate size $ + Text.intercalate "." + [ label + , fromString $ selName (undefined :: t c f a) + ] + gdestroy env (M1 a) = gdestroy env a + +instance VertexBuffers a => GVertexBuffers (K1 r a) where + gcreate size label = fmap K1 $ createInitial size label + gdestroy env (K1 a) = destroyCurrent env a + +-- TODO: class UpdateStaged bufs stores + +class UpdateCoherent bufs stores where + updateCoherent :: forall env m . MonadVulkan env m => bufs -> stores -> m bufs + + default updateCoherent + :: forall env m + . ( Generic bufs + , Generic stores + , GUpdateCoherent (Rep bufs) (Rep stores) + , MonadVulkan env m + ) + => bufs + -> stores + -> m bufs + updateCoherent = genericUpdateCoherent + +genericUpdateCoherent + :: ( Generic bufs + , Generic stores + , GUpdateCoherent (Rep bufs) (Rep stores) + , MonadVulkan env m + ) + => bufs + -> stores + -> m bufs +genericUpdateCoherent bufs stores = + fmap GHC.Generics.to $ + gUpdateCoherent + (GHC.Generics.from bufs) + (GHC.Generics.from stores) + +instance Storable a => UpdateCoherent (Buffer.Allocated 'Buffer.Coherent a) (Storable.Vector a) where + updateCoherent = Buffer.updateCoherentResize_ + +-- TODO: barbies-style update +-- instance (ApplicativeB collection) => UpdateCoherent (collection (Buffer.Allocated 'Buffer.Coherent)) (collection Storable.Vector) where +-- update = bzipWith Buffer.updateCoherentResize_ + +class GUpdateCoherent (fb :: Type -> Type) (fs :: Type -> Type) where + gUpdateCoherent :: forall env m b s . MonadVulkan env m => fb b -> fs s -> m (fb b) + +instance GUpdateCoherent fb fs => GUpdateCoherent (M1 c cb fb) (M1 c cs fs) where + gUpdateCoherent (M1 gb) (M1 gs) = fmap M1 $ gUpdateCoherent gb gs + +instance (GUpdateCoherent fbl fsl, GUpdateCoherent fbr fsr) => GUpdateCoherent (fbl :*: fbr) (fsl :*: fsr) where + gUpdateCoherent (bl :*: br) (sl :*: sr) = (:*:) + <$> gUpdateCoherent bl sl + <*> gUpdateCoherent br sr + +instance UpdateCoherent ba sa => GUpdateCoherent (K1 br ba) (K1 sr sa) where + gUpdateCoherent (K1 gb) (K1 gs) = fmap K1 $ updateCoherent gb gs diff --git a/src/Resource/Model/Observer/Example.hs b/src/Resource/Model/Observer/Example.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Model/Observer/Example.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Resource.Model.Observer.Example where + +import RIO + +import Control.Monad.Trans.Resource (ResourceT) +import Data.Vector.Storable qualified as Storable + +import Engine.Types (HKD, StageRIO) +import Engine.Vulkan.Types (MonadVulkan) +import Engine.Worker qualified as Worker +import Resource.Buffer qualified as Buffer +import Resource.Model.Observer qualified as Observer + +data ExampleF f = Example + { x :: HKD f Float + , y :: HKD f Float + } + deriving (Generic) + +type Example = ExampleF Identity +deriving instance Show Example +{- DON'T: instance GStorable Example. + +Vertex attributes are packed while GStorable gives something like std140. +-} + +type ExampleStores = ExampleF Storable.Vector +deriving instance Show ExampleStores + +type ExampleBuffers = ExampleF (Buffer.Allocated 'Buffer.Coherent) +deriving instance Show ExampleBuffers +instance Observer.VertexBuffers ExampleBuffers + +instance Observer.UpdateCoherent ExampleBuffers ExampleStores + +{-# DEPRECATED new "Just use Observer.newCoherent" #-} +new :: ResourceT (StageRIO st) (Worker.ObserverIO ExampleBuffers) +new = Observer.newCoherent 1 "SomeExample" + +{-# DEPRECATED update "Just use Observer.updateCoherent" #-} +update :: MonadVulkan env m => ExampleBuffers -> ExampleStores -> m ExampleBuffers +update = Observer.updateCoherent diff --git a/src/Resource/Source.hs b/src/Resource/Source.hs --- a/src/Resource/Source.hs +++ b/src/Resource/Source.hs @@ -1,4 +1,3 @@ - module Resource.Source ( Source(..) , load @@ -9,6 +8,7 @@ import Data.FileEmbed qualified import Data.Typeable +import GHC.Records (HasField(..)) import GHC.Stack (withFrozenCallStack) import Language.Haskell.TH.Syntax qualified as TH import Resource.Compressed.Zstd qualified as Zstd @@ -20,6 +20,13 @@ = Bytes (Maybe Text) ByteString | BytesZstd (Maybe Text) (Zstd.Compressed ByteString) | File (Maybe Text) FilePath + +instance HasField "label" Source (Maybe Text) where + {-# INLINE getField #-} + getField = \case + Bytes label _bytes -> label + BytesZstd label _bytes -> label + File label _path -> label instance Show Source where show = \case diff --git a/src/Resource/Texture.hs b/src/Resource/Texture.hs --- a/src/Resource/Texture.hs +++ b/src/Resource/Texture.hs @@ -2,7 +2,6 @@ module Resource.Texture ( Texture(..) - , destroy , TextureError(..) -- * Texture types @@ -12,8 +11,6 @@ , TextureLayers(..) -- * Utilities - , allocateCollectionWith - , allocateTextureWith , debugNameCollection , TextureLoader @@ -22,16 +19,20 @@ , imageAllocationCI , stageBufferCI , stageAllocationCI + + , withSize2d + , withSize3d ) where import RIO import Data.Bits ((.|.)) import Data.List qualified as List +import Geomancy (Vec2, vec2) import GHC.Stack (withFrozenCallStack) import GHC.TypeLits (Nat, KnownNat, natVal) +import GHC.Records (HasField(..)) 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 @@ -52,7 +53,7 @@ instance Exception TextureError -data Texture a = Texture +data Texture tag = Texture { tFormat :: Vk.Format , tMipLevels :: Word32 , tLayers :: Word32 -- ^ Actual number of layers, up to @ArrayOf a@ @@ -79,31 +80,8 @@ type TextureLoader m layers = Vk.Format -> Queues Vk.CommandPool -> FilePath -> m (Texture layers) -type TextureLoaderAction src m layers = src -> m (Texture layers) - -- * Allocation wrappers -allocateCollectionWith - :: (Resource.MonadResource m, MonadVulkan env m, Traversable t) - => TextureLoaderAction src m layers - -> t src - -> 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 src m layers - -> src - -> 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 @@ -127,10 +105,6 @@ -- * Implementation -destroy :: (MonadIO io, HasVulkan context) => context -> Texture a -> io () -destroy context Texture{tAllocatedImage} = - Image.destroy context tAllocatedImage - createImageView :: (MonadIO io, HasVulkan context) => context @@ -206,3 +180,30 @@ , VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU , VMA.requiredFlags = Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT } + +-- * Helpers + +{-# INLINE withSize2d #-} +withSize2d :: Num i => (i -> i -> a) -> Texture tag -> a +withSize2d f t = + f + (fromIntegral width) + (fromIntegral height) + where + Vk.Extent3D{width, height} = + Image.aiExtent (tAllocatedImage t) + +{-# INLINE withSize3d #-} +withSize3d :: Num i => (i -> i -> i -> a) -> Texture tag -> a +withSize3d f t = + f + (fromIntegral width) + (fromIntegral height) + (fromIntegral depth) + where + Vk.Extent3D{width, height, depth} = + Image.aiExtent (tAllocatedImage t) + +instance HasField "size" (Texture tag) Vec2 where + {-# INLINE getField #-} + getField = withSize2d vec2 diff --git a/src/Resource/Texture/Ktx1.hs b/src/Resource/Texture/Ktx1.hs --- a/src/Resource/Texture/Ktx1.hs +++ b/src/Resource/Texture/Ktx1.hs @@ -12,12 +12,12 @@ import Data.Vector qualified as Vector import Foreign qualified import GHC.Stack (withFrozenCallStack) +import UnliftIO.Resource (MonadResource) import Vulkan.Core10 qualified as Vk import Vulkan.Utils.FromGL qualified as FromGL import VulkanMemoryAllocator qualified as VMA import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, Queues) -import Resource.Image (AllocatedImage(..)) import Resource.Image qualified as Image import Resource.Source (Source(..)) import Resource.Source qualified as Source @@ -27,6 +27,7 @@ load :: ( TextureLayers a , MonadVulkan env m + , MonadResource m , MonadThrow m , HasLogFunc env , Typeable a @@ -42,6 +43,7 @@ loadBytes :: ( TextureLayers a , MonadVulkan env m + , MonadResource m , MonadThrow m , HasLogFunc env ) @@ -60,6 +62,7 @@ :: forall a m env . ( TextureLayers a , MonadVulkan env m + , MonadResource m , MonadThrow m , HasLogFunc env ) @@ -126,28 +129,17 @@ 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 + unless (numLayers == textureLayers @a) $ + throwM $ Texture.ArrayError (textureLayers @a) numLayers - Image.transitionLayout - context + dst <- Image.allocateDst pool - image + Nothing -- XXX: Name the whole collection later, tagging source with its index. + extent mipLevels - numLayers -- XXX: arrayLayers is always 0 for now + numLayers 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 mipImages = Vector.zip offsets images Vector.iforM_ mipImages \mipIx (offset, Ktx1.MipLevel{imageSize, arrayElements}) -> do @@ -183,53 +175,15 @@ VMA.flushAllocation vma stage 0 Vk.WHOLE_SIZE - -- XXX: copying to image while the staging buffer is still alive - Image.copyBufferToImage - context + final <- Image.copyBufferToDst pool staging - image - extent + dst offsets - numLayers - -- XXX: staging buffer is gone - - Image.transitionLayout - 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 - extent2d = - let - Vk.Extent3D{..} = extent - in - Vk.Extent2D{..} - - allocatedImage = AllocatedImage - { aiAllocation = allocation - , aiExtent = extent2d - , aiFormat = format - , aiImage = image - , aiImageView = imageView - , aiImageRange = Image.subresource Vk.IMAGE_ASPECT_COLOR_BIT mipLevels numLayers + pure Texture + { tFormat = format + , tMipLevels = mipLevels + , tLayers = numLayers + , tAllocatedImage = final } - pure Texture - { tFormat = format - , tMipLevels = mipLevels - , tLayers = numLayers - , tAllocatedImage = allocatedImage - } diff --git a/src/Resource/Texture/Ktx2.hs b/src/Resource/Texture/Ktx2.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Texture/Ktx2.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NoForeignFunctionInterface #-} + +module Resource.Texture.Ktx2 + ( load + , loadBytes + , loadKtx2 + ) where + +import RIO + +import Codec.Compression.Zstd.FFI qualified as Zstd +import Codec.Ktx.KeyValue qualified as KeyValue +import Codec.Ktx2.Header qualified as Header +import Codec.Ktx2.Level qualified as Level +import Codec.Ktx2.Read qualified as Read +import Data.Vector qualified as Vector +import Foreign qualified +import GHC.Stack (withFrozenCallStack) +import UnliftIO.Resource (MonadResource) +import Vulkan.Core10 qualified as Vk +import VulkanMemoryAllocator qualified as VMA + +import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, Queues) +import Resource.Image qualified as Image +import Resource.Source (Source(..)) +import Resource.Source qualified as Source +import Resource.Texture (Texture(..), TextureLayers(..)) +import Resource.Texture qualified as Texture + +load + :: ( TextureLayers a + , MonadVulkan env m + , MonadResource m + , MonadThrow m + , HasLogFunc env + , Typeable a + , HasCallStack + ) + => Queues Vk.CommandPool + -> Source + -> m (Texture a) +load pool source = + withFrozenCallStack $ + case source of + Source.File label path -> + -- XXX: the codec has a more efficient loader for files + loadFile label pool path + _bytes -> + Source.load (loadBytes source.label pool) source + +loadFile + :: ( TextureLayers a + , MonadVulkan env m + , MonadResource m + , MonadThrow m + , HasLogFunc env + ) + => Maybe Text + -> Queues Vk.CommandPool + -> FilePath + -> m (Texture a) +loadFile label pool path = + bracket (Read.open path) Read.close $ + loadKtx2 (label <|> Just (fromString path)) pool + +loadBytes + :: ( TextureLayers a + , MonadVulkan env m + , MonadResource m + , MonadThrow m + , HasLogFunc env + ) + => Maybe Text + -> Queues Vk.CommandPool + -> ByteString + -> m (Texture a) +loadBytes label pool bytes = + Read.bytes bytes >>= loadKtx2 label pool + +loadKtx2 + :: forall a m env src + . ( TextureLayers a + , MonadVulkan env m + , MonadResource m + , MonadThrow m + , HasLogFunc env + , Read.ReadChunk src + , Read.ReadLevel src + ) + => Maybe Text + -> Queues Vk.CommandPool + -> Read.Context src + -> m (Texture a) +loadKtx2 label pool ktx2@(Read.Context _src header) = do + logDebug $ displayShow (label, header) + + kvd <- Read.keyValueData ktx2 + logDebug $ displayShow (label, format, extent, numLayers, KeyValue.textual kvd) + + levels <- Read.levels ktx2 + + unless (Vector.length levels > 0) $ + throwString "Ktx2 contains no image levels" + + unless (Vector.length levels == fromIntegral header.levelCount) $ + throwString $ "Ktx2 level count mismatch " <> show (Vector.length levels, header.levelCount) + + unless (numLayers == textureLayers @a) $ + throwM $ Texture.ArrayError (textureLayers @a) numLayers + + let + levelSizes = fmap (fromIntegral . (.uncompressedByteLength)) levels + totalSize = Vector.sum levelSizes + offsets = Vector.init $ Vector.scanl' (+) 0 levelSizes + + dst <- Image.allocateDst + pool + label + extent + (fromIntegral $ Vector.length levels) + numLayers + format + + vma <- asks getAllocator + VMA.withBuffer vma (Texture.stageBufferCI totalSize) Texture.stageAllocationCI bracket \(staging, stage, stageInfo) -> do + liftIO case header.supercompressionScheme of + Header.SC_NONE -> + Vector.forM_ (Vector.zip offsets levels) \(offset, level) -> + liftIO . Read.levelToPtr ktx2 level $ + Foreign.plusPtr (VMA.mappedData stageInfo) offset + + Header.SC_ZSTANDARD -> do + let maxSize = Vector.maximum levelSizes + Foreign.allocaBytesAligned maxSize 16 \src -> + Vector.forM_ (Vector.zip offsets levels) \(offset, level) -> do + let expected = fromIntegral level.uncompressedByteLength + Read.levelToPtr ktx2 level src + + res <- + Zstd.checkError $ + Zstd.decompress + (Foreign.plusPtr (VMA.mappedData stageInfo) offset) + expected + src + (fromIntegral level.byteLength) + case res of + Right size | size == expected -> + pure () + Right unexpected -> + throwString $ + "Zstd decompressed unexpected amount of bytes: " <> show (unexpected, expected) + Left err -> + throwString err + + huh -> + error $ "Unexpected supercompression scheme: " ++ show huh + + VMA.flushAllocation vma stage 0 Vk.WHOLE_SIZE + + final <- Image.copyBufferToDst + pool + staging + dst + offsets + + pure Texture + { tFormat = format + , tMipLevels = header.levelCount + , tLayers = numLayers + , tAllocatedImage = final + } + where + format = Vk.Format (fromIntegral header.vkFormat) + + extent = Vk.Extent3D + { width = header.pixelWidth + , height = header.pixelHeight + , depth = max 1 header.pixelDepth + } + + -- XXX: can be flat array or a cubemap + numLayers = max header.faceCount header.layerCount diff --git a/src/Resource/Vulkan/DescriptorLayout.hs b/src/Resource/Vulkan/DescriptorLayout.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Vulkan/DescriptorLayout.hs @@ -0,0 +1,47 @@ +module Resource.Vulkan.DescriptorLayout where + +import RIO + +import Data.Vector qualified as Vector +import Engine.Vulkan.Types (getDevice, MonadVulkan) +import RIO.List qualified as List +import Vulkan.Core10 qualified as Vk +import Vulkan.Core12 qualified as Vk12 +import Vulkan.CStruct.Extends (pattern (:&), pattern (::&)) +import Vulkan.Zero (zero) + +create + :: MonadVulkan env m + => Vector [(Vk.DescriptorSetLayoutBinding, Vk12.DescriptorBindingFlags)] + -> m (Vector Vk.DescriptorSetLayout) +create dsBindings = do + device <- asks getDevice + Vector.forM dsBindings \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 + +forPipeline + :: MonadVulkan env m + => Vector Vk.DescriptorSetLayout + -> Vector Vk.PushConstantRange + -> m Vk.PipelineLayout +forPipeline dsLayouts pushConstantRanges = do + device <- asks getDevice + Vk.createPipelineLayout device layoutCI Nothing + where + layoutCI = Vk.PipelineLayoutCreateInfo + { flags = zero + , setLayouts = dsLayouts + , pushConstantRanges = pushConstantRanges + } diff --git a/src/Resource/Vulkan/DescriptorPool.hs b/src/Resource/Vulkan/DescriptorPool.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Vulkan/DescriptorPool.hs @@ -0,0 +1,64 @@ +module Resource.Vulkan.DescriptorPool + ( allocate + + , allocateSetsFrom + ) where + +import RIO + +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.Zero (zero) + +import Engine.Vulkan.Types (MonadVulkan, getDevice) +import Resource.Vulkan.Named qualified as Named + +allocate + :: ( MonadVulkan env m + , MonadResource m + ) + => Maybe Text + -> Word32 + -> [(Vk.DescriptorType, Word32)] + -> m (ReleaseKey, Vk.DescriptorPool) +allocate name maxSets sizes = do + device <- asks getDevice + res <- Vk.withDescriptorPool + device + poolCI + Nothing + Resource.allocate + for_ name $ + Named.object (snd res) + pure res + where + poolCI = zero + { Vk.maxSets = + maxSets + , Vk.poolSizes = + Vector.fromList $ + map (uncurry Vk.DescriptorPoolSize) sizes + } + +-- TODO: extract to Resource.Vulkan.DescriptorSets ? +allocateSetsFrom + :: MonadVulkan env m + => Vk.DescriptorPool + -> Maybe Text + -> Vector Vk.DescriptorSetLayout + -> m (Vector Vk.DescriptorSet) +allocateSetsFrom pool name layouts = do + device <- asks getDevice + descSets <- Vk.allocateDescriptorSets device zero + { Vk.descriptorPool = pool + , Vk.setLayouts = layouts + } + for_ name \prefix -> + Vector.iforM_ descSets \ix ds -> + Named.object ds $ mconcat + [ prefix + , "(set=", fromString (show ix), ")" + ] + pure descSets diff --git a/src/Resource/Vulkan/Named.hs b/src/Resource/Vulkan/Named.hs new file mode 100644 --- /dev/null +++ b/src/Resource/Vulkan/Named.hs @@ -0,0 +1,38 @@ +module Resource.Vulkan.Named + ( object + , objectOrigin + ) where + +import RIO + +import GHC.Stack (callStack, getCallStack, srcLocModule, withFrozenCallStack) +import RIO.List qualified as List +import Vulkan.Core10 qualified as Vk +import Vulkan.Utils.Debug qualified as Debug + +import Engine.Vulkan.Types (MonadVulkan, getDevice) + +object + :: ( MonadVulkan env m + , Vk.HasObjectType a + ) + => a + -> Text + -> m () +object o name = do + device <- asks getDevice + Debug.nameObject device o $ + encodeUtf8 name + +objectOrigin + :: ( MonadVulkan env m + , Vk.HasObjectType a + , HasCallStack + ) + => a + -> m () +objectOrigin o = + withFrozenCallStack $ + object o $ + fromString . List.intercalate "|" $ + map (srcLocModule . snd) (getCallStack callStack)