{-# LANGUAGE OverloadedRecordDot #-}
module Resource.Image
( AllocatedImage(..)
, 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.Zero (zero)
import VulkanMemoryAllocator qualified as VMA
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
{ AllocatedImage -> Allocation
aiAllocation :: VMA.Allocation
, AllocatedImage -> Extent3D
aiExtent :: Vk.Extent3D
, AllocatedImage -> Format
aiFormat :: Vk.Format
, AllocatedImage -> Image
aiImage :: Vk.Image
, AllocatedImage -> ImageView
aiImageView :: Vk.ImageView
, AllocatedImage -> ImageSubresourceRange
aiImageRange :: Vk.ImageSubresourceRange
}
deriving (Int -> AllocatedImage -> ShowS
[AllocatedImage] -> ShowS
AllocatedImage -> String
(Int -> AllocatedImage -> ShowS)
-> (AllocatedImage -> String)
-> ([AllocatedImage] -> ShowS)
-> Show AllocatedImage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AllocatedImage -> ShowS
showsPrec :: Int -> AllocatedImage -> ShowS
$cshow :: AllocatedImage -> String
show :: AllocatedImage -> String
$cshowList :: [AllocatedImage] -> ShowS
showList :: [AllocatedImage] -> ShowS
Show)
allocate
:: ( MonadVulkan env io
, MonadResource io
)
=> Maybe Text
-> Vk.ImageAspectFlags
-> "image dimensions" ::: Vk.Extent3D
-> "mip levels" ::: Word32
-> "stored layers" ::: Word32
-> Vk.SampleCountFlagBits
-> Vk.Format
-> Vk.ImageUsageFlags
-> io AllocatedImage
allocate :: forall env (io :: * -> *).
(MonadVulkan env io, MonadResource io) =>
Maybe Text
-> ImageAspectFlags
-> Extent3D
-> Word32
-> Word32
-> SampleCountFlagBits
-> Format
-> ImageUsageFlags
-> io AllocatedImage
allocate Maybe Text
mlabel ImageAspectFlags
aspect Extent3D
extent Word32
mipLevels Word32
numLayers SampleCountFlagBits
samples Format
format ImageUsageFlags
usage = do
Allocator
allocator <- (env -> Allocator) -> io Allocator
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Allocator
forall a. HasVulkan a => a -> Allocator
getAllocator
(Image
image, Allocation
allocation, AllocationInfo
_info) <- Allocator
-> ImageCreateInfo '[]
-> AllocationCreateInfo
-> io (Image, Allocation, AllocationInfo)
forall (a :: [*]) (io :: * -> *).
(Extendss ImageCreateInfo a, PokeChain a, MonadIO io) =>
Allocator
-> ImageCreateInfo a
-> AllocationCreateInfo
-> io (Image, Allocation, AllocationInfo)
VMA.createImage
Allocator
allocator
ImageCreateInfo '[]
imageCI
AllocationCreateInfo
imageAllocationCI
io ReleaseKey -> io ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (io ReleaseKey -> io ()) -> io ReleaseKey -> io ()
forall a b. (a -> b) -> a -> b
$! IO () -> io ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register (IO () -> io ReleaseKey) -> IO () -> io ReleaseKey
forall a b. (a -> b) -> a -> b
$
Allocator -> Image -> Allocation -> IO ()
forall (io :: * -> *).
MonadIO io =>
Allocator -> Image -> Allocation -> io ()
VMA.destroyImage Allocator
allocator Image
image Allocation
allocation
(Text -> io ()) -> Maybe Text -> io ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Image -> Text -> io ()
forall env (m :: * -> *) a.
(MonadVulkan env m, HasObjectType a) =>
a -> Text -> m ()
Named.object Image
image) Maybe Text
mlabel
ImageView
imageView <- Image -> Format -> ImageSubresourceRange -> io ImageView
forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
Image -> Format -> ImageSubresourceRange -> m ImageView
allocateView Image
image Format
format ImageSubresourceRange
subr
(Text -> io ()) -> Maybe Text -> io ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ImageView -> Text -> io ()
forall env (m :: * -> *) a.
(MonadVulkan env m, HasObjectType a) =>
a -> Text -> m ()
Named.object ImageView
imageView) (Maybe Text -> io ()) -> Maybe Text -> io ()
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":view") Maybe Text
mlabel
pure AllocatedImage
{ $sel:aiAllocation:AllocatedImage :: Allocation
aiAllocation = Allocation
allocation
, $sel:aiExtent:AllocatedImage :: Extent3D
aiExtent = Extent3D
extent
, $sel:aiFormat:AllocatedImage :: Format
aiFormat = Format
format
, $sel:aiImage:AllocatedImage :: Image
aiImage = Image
image
, $sel:aiImageView:AllocatedImage :: ImageView
aiImageView = ImageView
imageView
, $sel:aiImageRange:AllocatedImage :: ImageSubresourceRange
aiImageRange = ImageSubresourceRange
subr
}
where
imageType :: ImageType
imageType =
case Extent3D
extent of
Vk.Extent3D{$sel:depth:Extent3D :: Extent3D -> Word32
depth=Word32
1} ->
ImageType
Vk.IMAGE_TYPE_2D
Extent3D
_ ->
ImageType
Vk.IMAGE_TYPE_3D
imageCI :: ImageCreateInfo '[]
imageCI = ImageCreateInfo '[]
forall a. Zero a => a
zero
{ $sel:imageType:ImageCreateInfo :: ImageType
Vk.imageType = ImageType
imageType
, $sel:flags:ImageCreateInfo :: ImageCreateFlagBits
Vk.flags = ImageCreateFlagBits
createFlags
, $sel:format:ImageCreateInfo :: Format
Vk.format = Format
format
, $sel:extent:ImageCreateInfo :: Extent3D
Vk.extent = Extent3D
extent
, $sel:mipLevels:ImageCreateInfo :: Word32
Vk.mipLevels = Word32
mipLevels
, $sel:arrayLayers:ImageCreateInfo :: Word32
Vk.arrayLayers = Word32
numLayers
, $sel:tiling:ImageCreateInfo :: ImageTiling
Vk.tiling = ImageTiling
Vk.IMAGE_TILING_OPTIMAL
, $sel:initialLayout:ImageCreateInfo :: ImageLayout
Vk.initialLayout = ImageLayout
Vk.IMAGE_LAYOUT_UNDEFINED
, $sel:usage:ImageCreateInfo :: ImageUsageFlags
Vk.usage = ImageUsageFlags
usage
, $sel:sharingMode:ImageCreateInfo :: SharingMode
Vk.sharingMode = SharingMode
Vk.SHARING_MODE_EXCLUSIVE
, $sel:samples:ImageCreateInfo :: SampleCountFlagBits
Vk.samples = SampleCountFlagBits
samples
}
imageAllocationCI :: AllocationCreateInfo
imageAllocationCI = AllocationCreateInfo
forall a. Zero a => a
zero
{ $sel:usage:AllocationCreateInfo :: MemoryUsage
VMA.usage = MemoryUsage
VMA.MEMORY_USAGE_GPU_ONLY
, $sel:requiredFlags:AllocationCreateInfo :: MemoryPropertyFlags
VMA.requiredFlags = MemoryPropertyFlags
Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
}
createFlags :: ImageCreateFlagBits
createFlags =
case Word32
numLayers of
Word32
6 ->
ImageCreateFlagBits
Vk.IMAGE_CREATE_CUBE_COMPATIBLE_BIT
Word32
_ ->
ImageCreateFlagBits
forall a. Zero a => a
zero
subr :: ImageSubresourceRange
subr = ImageAspectFlags -> Word32 -> Word32 -> ImageSubresourceRange
subresource ImageAspectFlags
aspect Word32
mipLevels Word32
numLayers
allocateView
:: ( MonadVulkan env m
, MonadResource m
)
=> Vk.Image
-> Vk.Format
-> Vk.ImageSubresourceRange
-> m Vk.ImageView
allocateView :: forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
Image -> Format -> ImageSubresourceRange -> m ImageView
allocateView Image
image Format
format ImageSubresourceRange
subr = do
Device
device <- (env -> Device) -> m Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice
ImageView
imageView <- Device
-> ImageViewCreateInfo '[]
-> ("allocator" ::: Maybe AllocationCallbacks)
-> m ImageView
forall (a :: [*]) (io :: * -> *).
(Extendss ImageViewCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> ImageViewCreateInfo a
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ImageView
Vk.createImageView
Device
device
ImageViewCreateInfo '[]
imageViewCI
"allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing
m ReleaseKey -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ReleaseKey -> m ()) -> m ReleaseKey -> m ()
forall a b. (a -> b) -> a -> b
$! IO () -> m ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register (IO () -> m ReleaseKey) -> IO () -> m ReleaseKey
forall a b. (a -> b) -> a -> b
$ Device
-> ImageView
-> ("allocator" ::: Maybe AllocationCallbacks)
-> IO ()
forall (io :: * -> *).
MonadIO io =>
Device
-> ImageView
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ()
Vk.destroyImageView Device
device ImageView
imageView "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing
pure ImageView
imageView
where
imageViewCI :: ImageViewCreateInfo '[]
imageViewCI = ImageViewCreateInfo '[]
forall a. Zero a => a
zero
{ $sel:image:ImageViewCreateInfo :: Image
Vk.image = Image
image
, $sel:viewType:ImageViewCreateInfo :: ImageViewType
Vk.viewType = ImageSubresourceRange -> ImageViewType
guessViewType ImageSubresourceRange
subr
, $sel:format:ImageViewCreateInfo :: Format
Vk.format = Format
format
, $sel:components:ImageViewCreateInfo :: ComponentMapping
Vk.components = ComponentMapping
forall a. Zero a => a
zero
, $sel:subresourceRange:ImageViewCreateInfo :: ImageSubresourceRange
Vk.subresourceRange = ImageSubresourceRange
subr
}
newtype DstImage = DstImage AllocatedImage
allocateDst
:: ( MonadVulkan env m
, MonadResource m
)
=> Queues Vk.CommandPool
-> Maybe Text
-> ("image dimensions" ::: Vk.Extent3D)
-> ("mip levels" ::: Word32)
-> ("stored layers" ::: Word32)
-> Vk.Format
-> m DstImage
allocateDst :: forall env (m :: * -> *).
(MonadVulkan env m, MonadResource m) =>
Queues CommandPool
-> Maybe Text
-> Extent3D
-> Word32
-> Word32
-> Format
-> m DstImage
allocateDst Queues CommandPool
pool Maybe Text
name Extent3D
extent3d Word32
mipLevels Word32
numLayers Format
format = do
AllocatedImage
ai <- Maybe Text
-> ImageAspectFlags
-> Extent3D
-> Word32
-> Word32
-> SampleCountFlagBits
-> Format
-> ImageUsageFlags
-> m AllocatedImage
forall env (io :: * -> *).
(MonadVulkan env io, MonadResource io) =>
Maybe Text
-> ImageAspectFlags
-> Extent3D
-> Word32
-> Word32
-> SampleCountFlagBits
-> Format
-> ImageUsageFlags
-> io AllocatedImage
allocate
Maybe Text
name
ImageAspectFlags
Vk.IMAGE_ASPECT_COLOR_BIT
Extent3D
extent3d
Word32
mipLevels
Word32
numLayers
SampleCountFlagBits
Vk.SAMPLE_COUNT_1_BIT
Format
format
(ImageUsageFlags
Vk.IMAGE_USAGE_SAMPLED_BIT ImageUsageFlags -> ImageUsageFlags -> ImageUsageFlags
forall a. Bits a => a -> a -> a
.|. ImageUsageFlags
Vk.IMAGE_USAGE_TRANSFER_DST_BIT)
Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ImageLayout
-> ImageLayout
-> m ()
forall env (m :: * -> *).
MonadVulkan env m =>
Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ImageLayout
-> ImageLayout
-> m ()
transitionLayout
Queues CommandPool
pool
(AllocatedImage -> Image
aiImage AllocatedImage
ai)
Word32
mipLevels
Word32
numLayers
Format
format
ImageLayout
Vk.IMAGE_LAYOUT_UNDEFINED
ImageLayout
Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
pure $ AllocatedImage -> DstImage
DstImage AllocatedImage
ai
copyBufferToDst
:: ( MonadVulkan env m
, Integral deviceSize
, Foldable t
)
=> Queues Vk.CommandPool
-> Vk.Buffer
-> DstImage
-> "mip offsets" ::: t deviceSize
-> m AllocatedImage
copyBufferToDst :: forall env (m :: * -> *) deviceSize (t :: * -> *).
(MonadVulkan env m, Integral deviceSize, Foldable t) =>
Queues CommandPool
-> Buffer
-> DstImage
-> ("mip offsets" ::: t deviceSize)
-> m AllocatedImage
copyBufferToDst Queues CommandPool
pool Buffer
source (DstImage AllocatedImage
ai) "mip offsets" ::: t deviceSize
offsets = do
Queues CommandPool
-> Buffer
-> Image
-> Extent3D
-> ("mip offsets" ::: t deviceSize)
-> Word32
-> m ()
forall (t :: * -> *) deviceSize env (m :: * -> *).
(Foldable t, Integral deviceSize, MonadVulkan env m) =>
Queues CommandPool
-> Buffer
-> Image
-> Extent3D
-> ("mip offsets" ::: t deviceSize)
-> Word32
-> m ()
copyBufferToImage
Queues CommandPool
pool
Buffer
source
(AllocatedImage -> Image
aiImage AllocatedImage
ai)
(AllocatedImage -> Extent3D
aiExtent AllocatedImage
ai)
"mip offsets" ::: t deviceSize
offsets
Word32
layerCount
Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ImageLayout
-> ImageLayout
-> m ()
forall env (m :: * -> *).
MonadVulkan env m =>
Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ImageLayout
-> ImageLayout
-> m ()
transitionLayout
Queues CommandPool
pool
(AllocatedImage -> Image
aiImage AllocatedImage
ai)
Word32
levelCount
Word32
layerCount
(AllocatedImage -> Format
aiFormat AllocatedImage
ai)
ImageLayout
Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
ImageLayout
Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
pure AllocatedImage
ai
where
Vk.ImageSubresourceRange{Word32
layerCount :: Word32
$sel:layerCount:ImageSubresourceRange :: ImageSubresourceRange -> Word32
layerCount, Word32
levelCount :: Word32
$sel:levelCount:ImageSubresourceRange :: ImageSubresourceRange -> Word32
levelCount} = AllocatedImage -> ImageSubresourceRange
aiImageRange AllocatedImage
ai
{-# INLINE updateFromStorable #-}
updateFromStorable
:: ( Storable a
, MonadVulkan env m
, MonadResource m
)
=> Queues Vk.CommandPool
-> AllocatedImage
-> Storable.Vector a
-> m AllocatedImage
updateFromStorable :: forall a env (m :: * -> *).
(Storable a, MonadVulkan env m, MonadResource m) =>
Queues CommandPool
-> AllocatedImage -> Vector a -> m AllocatedImage
updateFromStorable Queues CommandPool
pools AllocatedImage
ai Vector a
update = do
(ReleaseKey
_transient, Allocated 'Coherent a
staging) <-
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (ReleaseKey, Allocated 'Coherent a)
forall env (m :: * -> *) a.
(MonadVulkan env m, MonadResource m, Storable a) =>
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (ReleaseKey, Allocated 'Coherent a)
Buffer.allocateCoherent
(Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"updateFromStorable:staging")
BufferUsageFlagBits
Vk.BUFFER_USAGE_TRANSFER_SRC_BIT
Int
1
Vector a
update
Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ImageLayout
-> ImageLayout
-> m ()
forall env (m :: * -> *).
MonadVulkan env m =>
Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ImageLayout
-> ImageLayout
-> m ()
transitionLayout
Queues CommandPool
pools
AllocatedImage
ai.aiImage
Word32
1
Word32
1
AllocatedImage
ai.aiFormat
ImageLayout
Vk.IMAGE_LAYOUT_UNDEFINED
ImageLayout
Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
Queues CommandPool
-> Buffer
-> Image
-> Extent3D
-> ("mip offsets" ::: Vector Word32)
-> Word32
-> m ()
forall (t :: * -> *) deviceSize env (m :: * -> *).
(Foldable t, Integral deviceSize, MonadVulkan env m) =>
Queues CommandPool
-> Buffer
-> Image
-> Extent3D
-> ("mip offsets" ::: t deviceSize)
-> Word32
-> m ()
copyBufferToImage
Queues CommandPool
pools
Allocated 'Coherent a
staging.aBuffer
AllocatedImage
ai.aiImage
(Word32 -> Word32 -> Word32 -> Extent3D
Vk.Extent3D AllocatedImage
ai.aiExtent.width AllocatedImage
ai.aiExtent.height Word32
1)
(Word32 -> "mip offsets" ::: Vector Word32
forall (v :: * -> *) a. Vector v a => a -> v a
Vector.singleton Word32
0 :: Vector Word32)
Word32
1
Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ImageLayout
-> ImageLayout
-> m ()
forall env (m :: * -> *).
MonadVulkan env m =>
Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ImageLayout
-> ImageLayout
-> m ()
transitionLayout
Queues CommandPool
pools
AllocatedImage
ai.aiImage
Word32
1
Word32
1
AllocatedImage
ai.aiFormat
ImageLayout
Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
ImageLayout
Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
pure AllocatedImage
ai
{-# INLINE transitionLayout #-}
transitionLayout
:: ( MonadVulkan env m
)
=> Queues Vk.CommandPool
-> Vk.Image
-> "mip levels" ::: Word32
-> "layer count" ::: Word32
-> Vk.Format
-> "old" ::: Vk.ImageLayout
-> "new" ::: Vk.ImageLayout
-> m ()
transitionLayout :: forall env (m :: * -> *).
MonadVulkan env m =>
Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ImageLayout
-> ImageLayout
-> m ()
transitionLayout Queues CommandPool
pool Image
image Word32
mipLevels Word32
layerCount Format
format ImageLayout
old ImageLayout
new = do
env
ctx <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
case (ImageLayout
old, ImageLayout
new) of
(ImageLayout
Vk.IMAGE_LAYOUT_UNDEFINED, ImageLayout
Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL) ->
env
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
oneshot_ env
ctx Queues CommandPool
pool Queues a -> a
forall a. Queues a -> a
qTransfer \CommandBuffer
buf ->
CommandBuffer
-> ("srcStageMask" ::: PipelineStageFlags)
-> ("srcStageMask" ::: PipelineStageFlags)
-> DependencyFlags
-> Vector MemoryBarrier
-> Vector BufferMemoryBarrier
-> ("imageMemoryBarriers"
::: Vector (SomeStruct ImageMemoryBarrier))
-> m ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> ("srcStageMask" ::: PipelineStageFlags)
-> ("srcStageMask" ::: PipelineStageFlags)
-> DependencyFlags
-> Vector MemoryBarrier
-> Vector BufferMemoryBarrier
-> ("imageMemoryBarriers"
::: Vector (SomeStruct ImageMemoryBarrier))
-> io ()
Vk.cmdPipelineBarrier
CommandBuffer
buf
"srcStageMask" ::: PipelineStageFlags
Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT
"srcStageMask" ::: PipelineStageFlags
Vk.PIPELINE_STAGE_TRANSFER_BIT
DependencyFlags
forall a. Zero a => a
zero
Vector MemoryBarrier
forall a. Monoid a => a
mempty
Vector BufferMemoryBarrier
forall a. Monoid a => a
mempty
( SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers" ::: Vector (SomeStruct ImageMemoryBarrier)
forall (v :: * -> *) a. Vector v a => a -> v a
Vector.singleton (SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers"
::: Vector (SomeStruct ImageMemoryBarrier))
-> SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers" ::: Vector (SomeStruct ImageMemoryBarrier)
forall a b. (a -> b) -> a -> b
$
ImageAspectFlags
-> AccessFlags -> AccessFlags -> SomeStruct ImageMemoryBarrier
barrier ImageAspectFlags
Vk.IMAGE_ASPECT_COLOR_BIT AccessFlags
forall a. Zero a => a
zero AccessFlags
Vk.ACCESS_TRANSFER_WRITE_BIT
)
(ImageLayout
Vk.IMAGE_LAYOUT_UNDEFINED, ImageLayout
Vk.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL) ->
env
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
oneshot_ env
ctx Queues CommandPool
pool Queues a -> a
forall a. Queues a -> a
qTransfer \CommandBuffer
buf ->
CommandBuffer
-> ("srcStageMask" ::: PipelineStageFlags)
-> ("srcStageMask" ::: PipelineStageFlags)
-> DependencyFlags
-> Vector MemoryBarrier
-> Vector BufferMemoryBarrier
-> ("imageMemoryBarriers"
::: Vector (SomeStruct ImageMemoryBarrier))
-> m ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> ("srcStageMask" ::: PipelineStageFlags)
-> ("srcStageMask" ::: PipelineStageFlags)
-> DependencyFlags
-> Vector MemoryBarrier
-> Vector BufferMemoryBarrier
-> ("imageMemoryBarriers"
::: Vector (SomeStruct ImageMemoryBarrier))
-> io ()
Vk.cmdPipelineBarrier
CommandBuffer
buf
"srcStageMask" ::: PipelineStageFlags
Vk.PIPELINE_STAGE_TOP_OF_PIPE_BIT
"srcStageMask" ::: PipelineStageFlags
Vk.PIPELINE_STAGE_EARLY_FRAGMENT_TESTS_BIT
DependencyFlags
forall a. Zero a => a
zero
Vector MemoryBarrier
forall a. Monoid a => a
mempty
Vector BufferMemoryBarrier
forall a. Monoid a => a
mempty
( SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers" ::: Vector (SomeStruct ImageMemoryBarrier)
forall (v :: * -> *) a. Vector v a => a -> v a
Vector.singleton (SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers"
::: Vector (SomeStruct ImageMemoryBarrier))
-> SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers" ::: Vector (SomeStruct ImageMemoryBarrier)
forall a b. (a -> b) -> a -> b
$
ImageAspectFlags
-> AccessFlags -> AccessFlags -> SomeStruct ImageMemoryBarrier
barrier ImageAspectFlags
aspectMask AccessFlags
forall a. Zero a => a
zero (AccessFlags -> SomeStruct ImageMemoryBarrier)
-> AccessFlags -> SomeStruct ImageMemoryBarrier
forall a b. (a -> b) -> a -> b
$
AccessFlags
Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_READ_BIT AccessFlags -> AccessFlags -> AccessFlags
forall a. Bits a => a -> a -> a
.|.
AccessFlags
Vk.ACCESS_DEPTH_STENCIL_ATTACHMENT_WRITE_BIT
)
where
aspectMask :: ImageAspectFlags
aspectMask =
if Bool
hasStencilComponent then
ImageAspectFlags
Vk.IMAGE_ASPECT_DEPTH_BIT ImageAspectFlags -> ImageAspectFlags -> ImageAspectFlags
forall a. Bits a => a -> a -> a
.|. ImageAspectFlags
Vk.IMAGE_ASPECT_STENCIL_BIT
else
ImageAspectFlags
Vk.IMAGE_ASPECT_DEPTH_BIT
hasStencilComponent :: Bool
hasStencilComponent =
Format
format Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
Vk.FORMAT_D32_SFLOAT_S8_UINT Bool -> Bool -> Bool
||
Format
format Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
Vk.FORMAT_D24_UNORM_S8_UINT
(ImageLayout
Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL, ImageLayout
Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL) ->
env
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
oneshot_ env
ctx Queues CommandPool
pool Queues a -> a
forall a. Queues a -> a
qGraphics \CommandBuffer
buf ->
CommandBuffer
-> ("srcStageMask" ::: PipelineStageFlags)
-> ("srcStageMask" ::: PipelineStageFlags)
-> DependencyFlags
-> Vector MemoryBarrier
-> Vector BufferMemoryBarrier
-> ("imageMemoryBarriers"
::: Vector (SomeStruct ImageMemoryBarrier))
-> m ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> ("srcStageMask" ::: PipelineStageFlags)
-> ("srcStageMask" ::: PipelineStageFlags)
-> DependencyFlags
-> Vector MemoryBarrier
-> Vector BufferMemoryBarrier
-> ("imageMemoryBarriers"
::: Vector (SomeStruct ImageMemoryBarrier))
-> io ()
Vk.cmdPipelineBarrier
CommandBuffer
buf
"srcStageMask" ::: PipelineStageFlags
Vk.PIPELINE_STAGE_TRANSFER_BIT
"srcStageMask" ::: PipelineStageFlags
Vk.PIPELINE_STAGE_FRAGMENT_SHADER_BIT
DependencyFlags
forall a. Zero a => a
zero
Vector MemoryBarrier
forall a. Monoid a => a
mempty
Vector BufferMemoryBarrier
forall a. Monoid a => a
mempty
( SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers" ::: Vector (SomeStruct ImageMemoryBarrier)
forall (v :: * -> *) a. Vector v a => a -> v a
Vector.singleton (SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers"
::: Vector (SomeStruct ImageMemoryBarrier))
-> SomeStruct ImageMemoryBarrier
-> "imageMemoryBarriers" ::: Vector (SomeStruct ImageMemoryBarrier)
forall a b. (a -> b) -> a -> b
$
ImageAspectFlags
-> AccessFlags -> AccessFlags -> SomeStruct ImageMemoryBarrier
barrier
ImageAspectFlags
Vk.IMAGE_ASPECT_COLOR_BIT
AccessFlags
Vk.ACCESS_TRANSFER_WRITE_BIT
AccessFlags
Vk.ACCESS_SHADER_READ_BIT
)
(ImageLayout, ImageLayout)
_ ->
String -> m ()
forall a. HasCallStack => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Unsupported image layout transfer: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (ImageLayout, ImageLayout) -> String
forall a. Show a => a -> String
show (ImageLayout
old, ImageLayout
new)
where
barrier :: ImageAspectFlags
-> AccessFlags -> AccessFlags -> SomeStruct ImageMemoryBarrier
barrier ImageAspectFlags
aspectMask AccessFlags
srcMask AccessFlags
dstMask = ImageMemoryBarrier '[] -> SomeStruct ImageMemoryBarrier
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct ImageMemoryBarrier '[]
forall a. Zero a => a
zero
{ $sel:srcAccessMask:ImageMemoryBarrier :: AccessFlags
Vk.srcAccessMask = AccessFlags
srcMask
, $sel:dstAccessMask:ImageMemoryBarrier :: AccessFlags
Vk.dstAccessMask = AccessFlags
dstMask
, $sel:oldLayout:ImageMemoryBarrier :: ImageLayout
Vk.oldLayout = ImageLayout
old
, $sel:newLayout:ImageMemoryBarrier :: ImageLayout
Vk.newLayout = ImageLayout
new
, $sel:srcQueueFamilyIndex:ImageMemoryBarrier :: Word32
Vk.srcQueueFamilyIndex = Word32
Vk.QUEUE_FAMILY_IGNORED
, $sel:dstQueueFamilyIndex:ImageMemoryBarrier :: Word32
Vk.dstQueueFamilyIndex = Word32
Vk.QUEUE_FAMILY_IGNORED
, $sel:image:ImageMemoryBarrier :: Image
Vk.image = Image
image
, $sel:subresourceRange:ImageMemoryBarrier :: ImageSubresourceRange
Vk.subresourceRange = ImageAspectFlags -> Word32 -> Word32 -> ImageSubresourceRange
subresource ImageAspectFlags
aspectMask Word32
mipLevels Word32
layerCount
}
{-# INLINE copyBufferToImage #-}
copyBufferToImage
:: ( Foldable t
, Integral deviceSize
, MonadVulkan env m
)
=> Queues Vk.CommandPool
-> Vk.Buffer
-> Vk.Image
-> "base extent" ::: Vk.Extent3D
-> "mip offsets" ::: t deviceSize
-> "layer count" ::: Word32
-> m ()
copyBufferToImage :: forall (t :: * -> *) deviceSize env (m :: * -> *).
(Foldable t, Integral deviceSize, MonadVulkan env m) =>
Queues CommandPool
-> Buffer
-> Image
-> Extent3D
-> ("mip offsets" ::: t deviceSize)
-> Word32
-> m ()
copyBufferToImage Queues CommandPool
pools Buffer
src Image
dst Vk.Extent3D{Word32
$sel:depth:Extent3D :: Extent3D -> Word32
width :: Word32
height :: Word32
depth :: Word32
$sel:width:Extent3D :: Extent3D -> Word32
$sel:height:Extent3D :: Extent3D -> Word32
..} "mip offsets" ::: t deviceSize
mipOffsets Word32
layerCount = do
env
context <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
env
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
oneshot_ env
context Queues CommandPool
pools Queues a -> a
forall a. Queues a -> a
qTransfer \CommandBuffer
cmd ->
CommandBuffer
-> Buffer
-> Image
-> ImageLayout
-> ("regions" ::: Vector BufferImageCopy)
-> m ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> Buffer
-> Image
-> ImageLayout
-> ("regions" ::: Vector BufferImageCopy)
-> io ()
Vk.cmdCopyBufferToImage CommandBuffer
cmd Buffer
src Image
dst ImageLayout
Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL (("regions" ::: Vector BufferImageCopy) -> m ())
-> ("regions" ::: Vector BufferImageCopy) -> m ()
forall a b. (a -> b) -> a -> b
$
[BufferImageCopy] -> "regions" ::: Vector BufferImageCopy
forall (v :: * -> *) a. Vector v a => [a] -> v a
Vector.fromList [BufferImageCopy]
copyRegions
where
copyRegions :: [BufferImageCopy]
copyRegions = do
(deviceSize
offset, Int
mipLevel) <- [deviceSize] -> [Int] -> [(deviceSize, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (("mip offsets" ::: t deviceSize) -> [deviceSize]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList "mip offsets" ::: t deviceSize
mipOffsets) [Int
0..]
BufferImageCopy -> [BufferImageCopy]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Vk.BufferImageCopy
{ $sel:bufferOffset:BufferImageCopy :: DeviceSize
Vk.bufferOffset = deviceSize -> DeviceSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral deviceSize
offset
, $sel:bufferRowLength:BufferImageCopy :: Word32
Vk.bufferRowLength = Word32
forall a. Zero a => a
zero
, $sel:bufferImageHeight:BufferImageCopy :: Word32
Vk.bufferImageHeight = Word32
forall a. Zero a => a
zero
, $sel:imageSubresource:BufferImageCopy :: ImageSubresourceLayers
Vk.imageSubresource = Vk.ImageSubresourceLayers
{ $sel:aspectMask:ImageSubresourceLayers :: ImageAspectFlags
aspectMask = ImageAspectFlags
Vk.IMAGE_ASPECT_COLOR_BIT
, $sel:mipLevel:ImageSubresourceLayers :: Word32
mipLevel = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mipLevel
, $sel:baseArrayLayer:ImageSubresourceLayers :: Word32
baseArrayLayer = Word32
0
, $sel:layerCount:ImageSubresourceLayers :: Word32
layerCount = Word32
layerCount
}
, $sel:imageOffset:BufferImageCopy :: Offset3D
Vk.imageOffset = Offset3D
forall a. Zero a => a
zero
, $sel:imageExtent:BufferImageCopy :: Extent3D
Vk.imageExtent = Vk.Extent3D
{ $sel:width:Extent3D :: Word32
width = Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1 (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Word32
width Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
mipLevel
, $sel:height:Extent3D :: Word32
height = Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1 (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Word32
height Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
mipLevel
, $sel:depth:Extent3D :: Word32
depth = Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1 (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Word32
depth Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
mipLevel
}
}
{-# INLINEABLE inflateExtent #-}
inflateExtent :: Vk.Extent2D -> Word32 -> Vk.Extent3D
inflateExtent :: Extent2D -> Word32 -> Extent3D
inflateExtent Vk.Extent2D{Word32
width :: Word32
height :: Word32
$sel:width:Extent2D :: Extent2D -> Word32
$sel:height:Extent2D :: Extent2D -> Word32
..} Word32
depth = Vk.Extent3D{Word32
$sel:depth:Extent3D :: Word32
$sel:width:Extent3D :: Word32
$sel:height:Extent3D :: Word32
width :: Word32
height :: Word32
depth :: Word32
..}
subresource
:: Vk.ImageAspectFlags
-> "mip levels" ::: Word32
-> "layer count" ::: Word32
-> Vk.ImageSubresourceRange
subresource :: ImageAspectFlags -> Word32 -> Word32 -> ImageSubresourceRange
subresource ImageAspectFlags
aspectMask Word32
mipLevels Word32
layerCount = Vk.ImageSubresourceRange
{ $sel:aspectMask:ImageSubresourceRange :: ImageAspectFlags
aspectMask = ImageAspectFlags
aspectMask
, $sel:baseMipLevel:ImageSubresourceRange :: Word32
baseMipLevel = Word32
0
, $sel:levelCount:ImageSubresourceRange :: Word32
levelCount = Word32
mipLevels
, $sel:baseArrayLayer:ImageSubresourceRange :: Word32
baseArrayLayer = Word32
0
, $sel:layerCount:ImageSubresourceRange :: Word32
layerCount = Word32
layerCount
}
guessViewType :: Vk.ImageSubresourceRange -> Vk.ImageViewType
guessViewType :: ImageSubresourceRange -> ImageViewType
guessViewType Vk.ImageSubresourceRange{Word32
$sel:layerCount:ImageSubresourceRange :: ImageSubresourceRange -> Word32
layerCount :: Word32
layerCount} =
case Word32
layerCount of
Word32
1 ->
ImageViewType
Vk.IMAGE_VIEW_TYPE_2D
Word32
6 ->
ImageViewType
Vk.IMAGE_VIEW_TYPE_CUBE
Word32
_ ->
ImageViewType
Vk.IMAGE_VIEW_TYPE_2D_ARRAY