diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,23 @@ # Changelog for keid-core +## 0.1.5.0 + +- Removed `allocateRenderpass_` from `RenderPass` class. +- Added `allocateRP` stage field. +- Added `Engine.Vulkan.Pipeline.Compute`. + * Common shader code extracted to `Engine.Vulkan.Shader`. +- Added shader specialization constants. + * Graphic and compute pipeline configs extended with `spec` parameter. + * `Shader.Specialization` class is used to derive vulkan schema at runtime and store values. +- Added `Pipline.Configure` and `Compute.Configure` families to produce a matching `Config` type. +- Added `cDepthCompare` to `Pipeline.Config`. +- Removed `Zero` instance for pipline configs. + * Use `baseConfig` value for better type inference and less imports. + +## 0.1.4.1 + +- Added size information to `Resource.Image`: `aiExtent`. + ## 0.1.4.0 - Changed `Render.Samplers.allocate` to use `maxAnisotropy` directly. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,1 +1,3 @@ # Keid Engine Core + +https://keid.haskell-game.dev diff --git a/keid-core.cabal b/keid-core.cabal --- a/keid-core.cabal +++ b/keid-core.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: keid-core -version: 0.1.4.0 +version: 0.1.5.0 synopsis: Core parts of Keid engine. category: Game Engine author: IC Rainbow @@ -46,6 +46,8 @@ Engine.UI.Layout Engine.Vulkan.DescSets Engine.Vulkan.Pipeline + Engine.Vulkan.Pipeline.Compute + Engine.Vulkan.Shader Engine.Vulkan.Swapchain Engine.Vulkan.Types Engine.Window.CursorPos diff --git a/src/Engine/Camera.hs b/src/Engine/Camera.hs --- a/src/Engine/Camera.hs +++ b/src/Engine/Camera.hs @@ -42,11 +42,22 @@ where -- BUG: infinitePerspective gives huge clipping and effective FoV is different -- projectionPerspective = Projection.infinitePerspective projectionFovRads width height - projectionPerspective = Projection.perspective projectionFovRads (1/2048) 16384 width height + projectionPerspective = Projection.perspective + projectionFovRads + PROJECTION_NEAR + PROJECTION_FAR + width + height projectionOrthoUI = Projection.orthoOffCenter 0 1 width height Vk.Extent2D{width, height} = projectionScreen + +pattern PROJECTION_NEAR :: (Eq a, Num a, Fractional a) => a +pattern PROJECTION_NEAR = 0x0.02 -- i.e. 1/2048 + +pattern PROJECTION_FAR :: (Eq a, Num a) => a +pattern PROJECTION_FAR = 16384 -- * View diff --git a/src/Engine/Frame.hs b/src/Engine/Frame.hs --- a/src/Engine/Frame.hs +++ b/src/Engine/Frame.hs @@ -73,7 +73,7 @@ void $! ResourceT.allocate_ debugAlloc debugRelease -- For each render pass: - sfRenderpass <- allocateRenderpass_ sfSwapchainResources + sfRenderpass <- sAllocateRP sfSwapchainResources -- TODO: Recreate this if the swapchain format changes sfPipelines <- sAllocateP sfSwapchainResources sfRenderpass diff --git a/src/Engine/Stage/Bootstrap/Setup.hs b/src/Engine/Stage/Bootstrap/Setup.hs --- a/src/Engine/Stage/Bootstrap/Setup.hs +++ b/src/Engine/Stage/Bootstrap/Setup.hs @@ -30,6 +30,7 @@ bootstrapStage handoff action = Engine.Stage { sTitle = "Bootstrap" + , sAllocateRP = noRendering , sAllocateP = noPipelines , sInitialRS = transitState handoff action , sInitialRR = noFrameResources @@ -39,6 +40,10 @@ , sRecordCommands = noCommands , sAfterLoop = pure } + +noRendering :: swapchain -> ResourceT (StageRIO st) NoRendering +noRendering _swapchain = + pure NoRendering noPipelines :: swapchain -> NoRendering -> ResourceT (StageRIO st) NoPipelines noPipelines _swapchain NoRendering = diff --git a/src/Engine/Stage/Bootstrap/Types.hs b/src/Engine/Stage/Bootstrap/Types.hs --- a/src/Engine/Stage/Bootstrap/Types.hs +++ b/src/Engine/Stage/Bootstrap/Types.hs @@ -15,7 +15,6 @@ data NoRendering = NoRendering instance RenderPass NoRendering where - allocateRenderpass_ _context = pure NoRendering updateRenderpass _context = pure refcountRenderpass _rp = pure () diff --git a/src/Engine/Types.hs b/src/Engine/Types.hs --- a/src/Engine/Types.hs +++ b/src/Engine/Types.hs @@ -101,6 +101,7 @@ data Stage rp p rr st = forall a . Stage { sTitle :: Text + , sAllocateRP :: SwapchainResources -> ResourceT (StageRIO st) rp , sAllocateP :: SwapchainResources -> rp -> ResourceT (StageRIO st) p , sInitialRS :: StageRIO (Maybe SwapchainResources) (ReleaseKey, st) , sInitialRR :: Vulkan.Queues Vk.CommandPool -> rp -> p -> ResourceT (StageRIO st) rr 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,10 +1,19 @@ -- XXX: TypeError in Compatible generates unused constraint argument {-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE OverloadedLists #-} + module Engine.Vulkan.Pipeline - ( Pipeline(..) - , Config(..) + ( Config(..) + , baseConfig + + , Configure + + , Pipeline(..) , allocate + , create + , destroy + , bind , pushPlaceholder @@ -33,6 +42,7 @@ import Engine.Vulkan.DescSets (Bound(..), Compatible) import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), MonadVulkan, DsBindings, DsLayouts, getPipelineCache) +import Engine.Vulkan.Shader qualified as Shader data Pipeline (dsl :: [Type]) vertices instances = Pipeline { pipeline :: Vk.Pipeline @@ -42,7 +52,10 @@ -- * Pipeline -data Config (dsl :: [Type]) vertices instances = Config +type family Configure pipeline spec where + Configure (Pipeline dsl vertices instances) spec = Config dsl vertices instances spec + +data Config (dsl :: [Type]) vertices instances spec = Config { cVertexCode :: Maybe ByteString , cFragmentCode :: Maybe ByteString , cVertexInput :: SomeStruct Vk.PipelineVertexInputStateCreateInfo @@ -51,25 +64,30 @@ , cBlend :: Bool , cDepthWrite :: Bool , cDepthTest :: Bool + , cDepthCompare :: Vk.CompareOp , cTopology :: Vk.PrimitiveTopology , cCull :: Vk.CullModeFlagBits , cDepthBias :: Maybe ("constant" ::: Float, "slope" ::: Float) + , cSpecialization :: spec } -instance Zero (Config dsl vertices instances) where - zero = Config - { cVertexCode = Nothing - , cFragmentCode = Nothing - , cVertexInput = zero - , cDescLayouts = Tagged [] -- FIXME: unsafe wrt. "dsl" - , cPushConstantRanges = mempty - , cBlend = False - , cDepthWrite = True - , cDepthTest = True - , cTopology = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST - , cCull = Vk.CULL_MODE_BACK_BIT - , cDepthBias = Nothing - } +-- | Settings for generic triangle-rendering pipeline. +baseConfig :: Config '[] vertices instances () +baseConfig = Config + { cVertexCode = Nothing + , cFragmentCode = Nothing + , cVertexInput = zero + , cDescLayouts = Tagged [] + , cPushConstantRanges = mempty + , cBlend = False + , cDepthWrite = True + , cDepthTest = True + , cDepthCompare = Vk.COMPARE_OP_LESS + , cTopology = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST + , cCull = Vk.CULL_MODE_BACK_BIT + , cDepthBias = Nothing + , cSpecialization = () + } -- XXX: consider using instance attrs or uniforms pushPlaceholder :: Vk.PushConstantRange @@ -86,11 +104,12 @@ :: ( MonadVulkan env m , MonadResource m , HasRenderPass renderpass + , Shader.Specialization spec , HasCallStack ) => Maybe Vk.Extent2D -> Vk.SampleCountFlagBits - -> Config dsl vertices instances + -> Config dsl vertices instances spec -> renderpass -> m (ReleaseKey, Pipeline dsl vertices instances) allocate extent msaa config renderpass = withFrozenCallStack do @@ -100,12 +119,17 @@ (destroy ctx) create - :: (MonadIO io, HasVulkan ctx, HasRenderPass renderpass, HasCallStack) + :: ( MonadUnliftIO io + , HasVulkan ctx + , HasRenderPass renderpass + , Shader.Specialization spec + , HasCallStack + ) => ctx -> Maybe Vk.Extent2D -> Vk.SampleCountFlagBits -> renderpass - -> Config dsl vertices instances + -> Config dsl vertices instances spec -> io (Pipeline dsl vertices instances) create context mextent msaa renderpass Config{..} = do let @@ -132,35 +156,35 @@ layout <- Vk.createPipelineLayout device (layoutCI dsLayouts) Nothing Debug.nameObject device layout originModule - let - codeStages = Vector.fromList $ case (cVertexCode, cFragmentCode) of - (Just vertCode, Just fragCode) -> - [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode) - , (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode) - ] + shader <- Shader.withSpecialization cSpecialization $ + Shader.create context $ + case (cVertexCode, cFragmentCode) of + (Just vertCode, Just fragCode) -> + [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode) + , (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode) + ] - (Just vertCode, Nothing) -> - [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode) - ] + (Just vertCode, Nothing) -> + [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode) + ] - (Nothing, Just fragCode) -> - -- XXX: good luck - [ (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode) - ] + (Nothing, Just fragCode) -> + -- XXX: good luck + [ (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode) + ] - (Nothing, Nothing) -> - [] - shader <- createShader context codeStages + (Nothing, Nothing) -> + [] let cis = Vector.singleton . SomeStruct $ - pipelineCI (sPipelineStages shader) layout + pipelineCI (Shader.sPipelineStages shader) layout Vk.createGraphicsPipelines device cache cis Nothing >>= \case (Vk.SUCCESS, pipelines) -> case Vector.toList pipelines of [one] -> do - destroyShader context shader + Shader.destroy context shader Debug.nameObject device one originModule pure Pipeline { pipeline = one @@ -202,7 +226,7 @@ , Vk.primitiveRestartEnable = restartable } - restartable = elem cTopology + restartable = elem @Set cTopology [ Vk.PRIMITIVE_TOPOLOGY_LINE_STRIP , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_STRIP , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_FAN @@ -273,7 +297,7 @@ depthStencilState = zero { Vk.depthTestEnable = cDepthTest , Vk.depthWriteEnable = cDepthWrite - , Vk.depthCompareOp = Vk.COMPARE_OP_LESS + , Vk.depthCompareOp = cDepthCompare , Vk.depthBoundsTestEnable = False , Vk.minDepthBounds = 0.0 -- Optional , Vk.maxDepthBounds = 1.0 -- Optional @@ -339,46 +363,6 @@ } attrs = attrBindings $ map snd bindings - --- * Shader code - -data Shader = Shader - { sModules :: Vector Vk.ShaderModule - , sPipelineStages :: Vector (SomeStruct Vk.PipelineShaderStageCreateInfo) - } - -createShader - :: (MonadIO io, HasVulkan ctx) - => ctx - -> Vector (Vk.ShaderStageFlagBits, ByteString) - -> io Shader -createShader context stages = do - staged <- Vector.forM stages \(stage, code) -> do - module_ <- Vk.createShaderModule - (getDevice context) - zero - { Vk.code = code - } - Nothing - pure - ( module_ - , SomeStruct zero - { Vk.stage = stage - , Vk.module' = module_ - , Vk.name = "main" - -- , Vk.specializationInfo = Nothing - } - ) - let (modules, pStages) = Vector.unzip staged - pure Shader - { sModules = modules - , sPipelineStages = pStages - } - -destroyShader :: (MonadIO io, HasVulkan ctx) => ctx -> Shader -> io () -destroyShader context Shader{sModules} = - Vector.forM_ sModules \module_ -> - Vk.destroyShaderModule (getDevice context) module_ Nothing -- * Utils diff --git a/src/Engine/Vulkan/Pipeline/Compute.hs b/src/Engine/Vulkan/Pipeline/Compute.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Vulkan/Pipeline/Compute.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedLists #-} + +-- XXX: TypeError in Compatible generates unused constraint argument +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Engine.Vulkan.Pipeline.Compute + ( Config(..) + , Configure + + , Pipeline(..) + , allocate + , create + , destroy + + , bind + , Compute + ) where + +import RIO + +import Data.Kind (Type) +import Data.List qualified as List +import Data.Tagged (Tagged(..)) +import Data.Vector qualified as Vector +import GHC.Stack (callStack, getCallStack, srcLocModule, 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.Zero (Zero(..)) + +import Engine.Vulkan.DescSets (Bound(..), Compatible) +import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, DsBindings, getPipelineCache) + +import Engine.Vulkan.Pipeline (Pipeline(..), destroy) +import Engine.Vulkan.Shader qualified as Shader + +data Config (dsl :: [Type]) spec = Config + { cComputeCode :: ByteString + , cDescLayouts :: Tagged dsl [DsBindings] + , cPushConstantRanges :: Vector Vk.PushConstantRange + , cSpecialization :: spec + } + +data Compute + +type family Configure pipeline spec where + Configure (Pipeline dsl Compute Compute) spec = Config dsl spec + +allocate + :: ( MonadVulkan env m + , MonadResource m + , HasCallStack + , Shader.Specialization spec + ) + => Config dsl spec + -> m (ReleaseKey, Pipeline dsl Compute Compute) +allocate config = withFrozenCallStack do + ctx <- ask + Resource.allocate + (create ctx config) + (destroy ctx) + +create + :: ( HasVulkan ctx + , MonadUnliftIO m + , Shader.Specialization spec + ) + => 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 + + -- Compute stuff begins... + + shader <- Shader.withSpecialization cSpecialization $ + Shader.create + context + [(Vk.SHADER_STAGE_COMPUTE_BIT, cComputeCode)] + + let + cis = Vector.singleton . SomeStruct $ + pipelineCI (Shader.sPipelineStages shader) layout + + Vk.createComputePipelines device cache cis Nothing >>= \case + (Vk.SUCCESS, pipelines) -> + case pipelines of + [one] -> do + Shader.destroy context shader + Debug.nameObject device one originModule + pure Pipeline + { pipeline = one + , pLayout = Tagged layout + , pDescLayouts = Tagged dsLayouts + } + _ -> + error "assert: exactly one pipeline requested" + (err, _) -> + throwString $ "createComputePipelines: " <> show err + + where + device = getDevice context + cache = getPipelineCache context + + layoutCI dsLayouts = Vk.PipelineLayoutCreateInfo + { flags = zero + , setLayouts = dsLayouts + , pushConstantRanges = cPushConstantRanges + } + + pipelineCI stages layout = zero + { Vk.layout = layout + , Vk.stage = stage + , Vk.basePipelineHandle = zero + } + where + stage = case stages of + [one] -> one + _assert -> error "compute code has one stage" + +bind + :: ( Compatible pipeLayout boundLayout + , MonadIO m + ) + => Vk.CommandBuffer + -> Pipeline pipeLayout vertices instances + -> Bound boundLayout vertices instances m () + -> Bound boundLayout oldVertices oldInstances m () +bind cb Pipeline{pipeline} (Bound attrAction) = do + Bound $ Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_COMPUTE pipeline + Bound attrAction diff --git a/src/Engine/Vulkan/Shader.hs b/src/Engine/Vulkan/Shader.hs new file mode 100644 --- /dev/null +++ b/src/Engine/Vulkan/Shader.hs @@ -0,0 +1,208 @@ +{-# OPTIONS_GHC -Wwarn=orphans #-} + +{-# LANGUAGE OverloadedLists #-} + +module Engine.Vulkan.Shader + ( Shader(..) + , create + , destroy + + , withSpecialization + , Specialization(..) + + , SpecializationConst(..) + ) where + +import RIO + +import Data.Vector qualified as Vector +import Data.Vector.Storable qualified as Storable +import Foreign qualified +import Vulkan.Core10 qualified as Vk +import Vulkan.CStruct.Extends (SomeStruct(..)) +import Vulkan.Zero (Zero(..)) +import Unsafe.Coerce (unsafeCoerce) + +import Engine.Vulkan.Types (HasVulkan(..)) + +data Shader = Shader + { sModules :: Vector Vk.ShaderModule + , sPipelineStages :: Vector (SomeStruct Vk.PipelineShaderStageCreateInfo) + } + +create + :: (MonadIO io, HasVulkan ctx) + => ctx + -> Vector (Vk.ShaderStageFlagBits, ByteString) + -> Maybe Vk.SpecializationInfo + -> io Shader +create context stages spec = do + staged <- Vector.forM stages \(stage, code) -> do + module_ <- Vk.createShaderModule + (getDevice context) + zero + { Vk.code = code + } + Nothing + + pure + ( module_ + , SomeStruct zero + { Vk.stage = stage + , Vk.module' = module_ + , Vk.name = "main" + , Vk.specializationInfo = spec + } + ) + let (modules, pStages) = Vector.unzip staged + pure Shader + { sModules = modules + , sPipelineStages = pStages + } + +destroy :: (MonadIO io, HasVulkan ctx) => ctx -> Shader -> io () +destroy context Shader{sModules} = + Vector.forM_ sModules \module_ -> + Vk.destroyShaderModule (getDevice context) module_ Nothing + +-- * Specialization constants + +withSpecialization + :: ( Specialization spec + , MonadUnliftIO m + ) + => spec + -> (Maybe Vk.SpecializationInfo -> m a) + -> m a +withSpecialization spec action = + case mapEntries of + [] -> + action Nothing + _some -> + withRunInIO \run -> + Storable.unsafeWith specData \specPtr -> + run . action $ Just Vk.SpecializationInfo + { mapEntries = mapEntries + , dataSize = fromIntegral $ Storable.length specData * 4 + , data' = Foreign.castPtr @_ @() specPtr + } + where + specData = Storable.fromList $ specializationData spec + + mapEntries = Vector.imap + (\ix _data -> Vk.SpecializationMapEntry + { constantID = fromIntegral ix + , offset = fromIntegral $ ix * 4 + , size = 4 + } + ) + (Vector.convert specData) + +class Specialization a where + -- XXX: abusing the fact that most scalars (sans double) are 4-wide + specializationData :: a -> [Word32] + +instance Specialization () where + specializationData = const [] + +instance Specialization [Word32] where + specializationData = id + +{- | + The constant_id can only be applied to a scalar *int*, a scalar *float* or a scalar *bool*. + (https://github.com/KhronosGroup/GLSL/blob/master/extensions/khr/GL_KHR_vulkan_glsl.txt) + + XXX: Apparently it is possible to pass uints and doubles too. +-} + +instance Specialization Word32 where + specializationData x = [packConstData x] + +instance Specialization Int32 where + specializationData x = [packConstData x] + +instance Specialization Float where + specializationData x = [packConstData x] + +instance Specialization Bool where + specializationData x = [packConstData x] + +class SpecializationConst a where + packConstData :: a -> Word32 + +instance SpecializationConst Word32 where + packConstData = id + +instance SpecializationConst Int32 where + packConstData = unsafeCoerce + +instance SpecializationConst Float where + packConstData = unsafeCoerce + +instance SpecializationConst Bool where + packConstData = bool 0 1 + +instance + ( SpecializationConst a + , SpecializationConst b + ) => Specialization (a, b) where + specializationData (a, b) = + [ packConstData a + , packConstData b + ] + +instance + ( SpecializationConst a + , SpecializationConst b + , SpecializationConst c + ) => Specialization (a, b, c) where + specializationData (a, b, c) = + [ packConstData a + , packConstData b + , packConstData c + ] + +instance + ( SpecializationConst a + , SpecializationConst b + , SpecializationConst c + , SpecializationConst d + ) => Specialization (a, b, c, d) where + specializationData (a, b, c, d) = + [ packConstData a + , packConstData b + , packConstData c + , packConstData d + ] + +instance + ( SpecializationConst a + , SpecializationConst b + , SpecializationConst c + , SpecializationConst d + , SpecializationConst e + ) => Specialization (a, b, c, d, e) where + specializationData (a, b, c, d, e) = + [ packConstData a + , packConstData b + , packConstData c + , packConstData d + , packConstData e + ] + +instance + ( SpecializationConst a + , SpecializationConst b + , SpecializationConst c + , SpecializationConst d + , SpecializationConst e + , SpecializationConst f + ) => Specialization (a, b, c, d, e, f) where + specializationData (a, b, c, d, e, f) = + [ packConstData a + , packConstData b + , packConstData c + , packConstData d + , packConstData e + , packConstData f + ] 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 @@ -20,7 +20,7 @@ import Data.Kind (Type) import RIO.App (App(..)) -import UnliftIO.Resource (MonadResource, ResourceT) +import UnliftIO.Resource (MonadResource) import Vulkan.Core10 qualified as Vk import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12 import Vulkan.NamedType ((:::)) @@ -99,24 +99,16 @@ getRenderArea :: a -> Vk.Rect2D class RenderPass a where - allocateRenderpass_ - :: ( HasLogFunc env - , HasSwapchain context - , HasVulkan env - , MonadResource (RIO env) - ) - => context - -> ResourceT (RIO env) a - updateRenderpass :: ( HasLogFunc env - , HasSwapchain context + , HasSwapchain swapchain , HasVulkan env , MonadResource (RIO env) ) - => context + => swapchain -> a -> RIO env a + updateRenderpass = const pure refcountRenderpass :: MonadResource (RIO env) diff --git a/src/Render/Code.hs b/src/Render/Code.hs --- a/src/Render/Code.hs +++ b/src/Render/Code.hs @@ -3,6 +3,7 @@ module Render.Code ( compileVert , compileFrag + , compileComp , glsl , trimming , Code(..) @@ -20,6 +21,9 @@ compileFrag :: String -> Q Exp compileFrag = compileShaderQ Nothing "frag" Nothing + +compileComp :: String -> Q Exp +compileComp = compileShaderQ Nothing "comp" Nothing -- | A wrapper to `show` code into `compileShaderQ` vars. newtype Code = Code { unCode :: Text } 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 @@ -64,9 +64,6 @@ getRenderArea = oRenderArea instance RenderPass Offscreen where - allocateRenderpass_ = error "Don't allocate Offscreen via class" - updateRenderpass = error "Don't recreate Offscreen on resize" - refcountRenderpass = resourceTRefCount . oRelease colorTexture :: Offscreen -> Texture Flat diff --git a/src/Resource/Image.hs b/src/Resource/Image.hs --- a/src/Resource/Image.hs +++ b/src/Resource/Image.hs @@ -23,6 +23,7 @@ data AllocatedImage = AllocatedImage { aiAllocation :: VMA.Allocation + , aiExtent :: Vk.Extent2D , aiFormat :: Vk.Format , aiImage :: Vk.Image , aiImageView :: Vk.ImageView @@ -37,14 +38,14 @@ => ctx -> Maybe Text -> Vk.ImageAspectFlags - -> Vk.Extent2D + -> "image dimensions" ::: Vk.Extent2D -> "mip levels" ::: Word32 -> "stored layers" ::: Word32 -> Vk.SampleCountFlagBits -> Vk.Format -> Vk.ImageUsageFlags -> io AllocatedImage -create context mlabel aspect Vk.Extent2D{width, height} mipLevels numLayers samples format usage = do +create context mlabel aspect extent mipLevels numLayers samples format usage = do let device = getDevice context allocator = getAllocator context @@ -65,12 +66,15 @@ pure AllocatedImage { aiAllocation = allocation + , aiExtent = extent , aiFormat = format , aiImage = image , aiImageView = imageView , aiImageRange = subr } where + Vk.Extent2D{width, height} = extent + imageCI = zero { Vk.imageType = Vk.IMAGE_TYPE_2D , Vk.flags = createFlags 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 @@ -216,8 +216,15 @@ numLayers let + extent2d = + let + Vk.Extent3D{..} = extent + in + Vk.Extent2D{..} + allocatedImage = AllocatedImage { aiAllocation = allocation + , aiExtent = extent2d , aiFormat = format , aiImage = image , aiImageView = imageView