module Resource.Buffer where
import RIO
import Data.Bits ((.|.))
import Data.Type.Equality (type (~))
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.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
data Allocated (s :: Store) a = Allocated
{ forall {k} (s :: Store) (a :: k). Allocated s a -> Buffer
aBuffer :: Vk.Buffer
, forall {k} (s :: Store) (a :: k). Allocated s a -> Allocation
aAllocation :: VMA.Allocation
, forall {k} (s :: Store) (a :: k). Allocated s a -> AllocationInfo
aAllocationInfo :: VMA.AllocationInfo
, forall {k} (s :: Store) (a :: k). Allocated s a -> Int
aCapacity :: Int
, forall {k} (s :: Store) (a :: k). Allocated s a -> Word32
aUsed :: Word32
, forall {k} (s :: Store) (a :: k).
Allocated s a -> BufferUsageFlagBits
aUsage :: Vk.BufferUsageFlagBits
, forall {k} (s :: Store) (a :: k). Allocated s a -> Maybe Text
aLabel :: Maybe Text
} deriving (Int -> Allocated s a -> ShowS
[Allocated s a] -> ShowS
Allocated s a -> String
(Int -> Allocated s a -> ShowS)
-> (Allocated s a -> String)
-> ([Allocated s a] -> ShowS)
-> Show (Allocated s a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Store) k (a :: k). Int -> Allocated s a -> ShowS
forall (s :: Store) k (a :: k). [Allocated s a] -> ShowS
forall (s :: Store) k (a :: k). Allocated s a -> String
$cshowsPrec :: forall (s :: Store) k (a :: k). Int -> Allocated s a -> ShowS
showsPrec :: Int -> Allocated s a -> ShowS
$cshow :: forall (s :: Store) k (a :: k). Allocated s a -> String
show :: Allocated s a -> String
$cshowList :: forall (s :: Store) k (a :: k). [Allocated s a] -> ShowS
showList :: [Allocated s a] -> ShowS
Show)
instance Vk.HasObjectType (Allocated s a) where
objectTypeAndHandle :: Allocated s a -> (ObjectType, Word64)
objectTypeAndHandle =
Buffer -> (ObjectType, Word64)
forall a. HasObjectType a => a -> (ObjectType, Word64)
Vk.objectTypeAndHandle (Buffer -> (ObjectType, Word64))
-> (Allocated s a -> Buffer)
-> Allocated s a
-> (ObjectType, Word64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Allocated s a -> Buffer
forall {k} (s :: Store) (a :: k). Allocated s a -> Buffer
aBuffer
allocateCoherent
:: ( 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 :: forall env (m :: * -> *) a.
(MonadVulkan env m, MonadResource m, Storable a) =>
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (ReleaseKey, Allocated 'Coherent a)
allocateCoherent Maybe Text
label BufferUsageFlagBits
usage Int
initialSize Vector a
xs = do
Allocated 'Coherent a
res <- Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (Allocated 'Coherent a)
forall a env (m :: * -> *).
(MonadVulkan env m, Storable a) =>
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (Allocated 'Coherent a)
createCoherent Maybe Text
label BufferUsageFlagBits
usage Int
initialSize Vector a
xs
IO ()
destroyIO <- m () -> m (IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO do
env
context <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
env -> Allocated 'Coherent a -> m ()
forall {k} (io :: * -> *) context (s :: Store) (a :: k).
(MonadUnliftIO io, HasVulkan context) =>
context -> Allocated s a -> io ()
destroy env
context Allocated 'Coherent a
res
ReleaseKey
key <- IO () -> m ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register IO ()
destroyIO
pure (ReleaseKey
key, Allocated 'Coherent a
res)
createCoherent
:: forall a env m
. ( MonadVulkan env m
, Storable a
)
=> Maybe Text
-> Vk.BufferUsageFlagBits
-> "initial size" ::: Int
-> VectorS.Vector a
-> m (Allocated 'Coherent a)
createCoherent :: forall a env (m :: * -> *).
(MonadVulkan env m, Storable a) =>
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (Allocated 'Coherent a)
createCoherent Maybe Text
aLabel BufferUsageFlagBits
usage Int
initialSize Vector a
xs = do
Allocator
allocator <- (env -> Allocator) -> m Allocator
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Allocator
forall a. HasVulkan a => a -> Allocator
getAllocator
(Buffer
aBuffer, Allocation
aAllocation, AllocationInfo
aAllocationInfo) <- Allocator
-> BufferCreateInfo '[]
-> AllocationCreateInfo
-> m (Buffer, Allocation, AllocationInfo)
forall (a :: [*]) (io :: * -> *).
(Extendss BufferCreateInfo a, PokeChain a, MonadIO io) =>
Allocator
-> BufferCreateInfo a
-> AllocationCreateInfo
-> io (Buffer, Allocation, AllocationInfo)
VMA.createBuffer Allocator
allocator BufferCreateInfo '[]
bci AllocationCreateInfo
aci
(Text -> m ()) -> Maybe Text -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Buffer -> Text -> m ()
forall env (m :: * -> *) a.
(MonadVulkan env m, HasObjectType a) =>
a -> Text -> m ()
Named.object Buffer
aBuffer) Maybe Text
aLabel
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
if AllocationInfo -> Ptr ()
VMA.mappedData AllocationInfo
aAllocationInfo Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
Foreign.nullPtr then
String -> m ()
forall a. HasCallStack => String -> a
error String
"TODO: recover from unmapped data and flush manually"
else
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Vector a -> (Ptr a -> IO ()) -> IO ()
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
VectorS.unsafeWith Vector a
xs \Ptr a
src ->
Ptr a -> Ptr a -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyBytes (Ptr () -> Ptr a
forall a b. Ptr a -> Ptr b
Foreign.castPtr (Ptr () -> Ptr a) -> Ptr () -> Ptr a
forall a b. (a -> b) -> a -> b
$ AllocationInfo -> Ptr ()
VMA.mappedData AllocationInfo
aAllocationInfo) Ptr a
src Int
lenBytes
pure Allocated
{ $sel:aCapacity:Allocated :: Int
aCapacity = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
initialSize Int
len
, $sel:aUsed:Allocated :: Word32
aUsed = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
, $sel:aUsage:Allocated :: BufferUsageFlagBits
aUsage = BufferUsageFlagBits
usage
, Maybe Text
AllocationInfo
Allocation
Buffer
$sel:aBuffer:Allocated :: Buffer
$sel:aAllocation:Allocated :: Allocation
$sel:aAllocationInfo:Allocated :: AllocationInfo
$sel:aLabel:Allocated :: Maybe Text
aLabel :: Maybe Text
aBuffer :: Buffer
aAllocation :: Allocation
aAllocationInfo :: AllocationInfo
..
}
where
len :: Int
len = Vector a -> Int
forall a. Storable a => Vector a -> Int
VectorS.length Vector a
xs
lenBytes :: Int
lenBytes = a -> Int
forall a. Storable a => a -> Int
Foreign.sizeOf (a
forall a. HasCallStack => a
undefined :: a) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
len
sizeBytes :: Int
sizeBytes = a -> Int
forall a. Storable a => a -> Int
Foreign.sizeOf (a
forall a. HasCallStack => a
undefined :: a) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
initialSize Int
len
bci :: BufferCreateInfo '[]
bci = BufferCreateInfo '[]
forall a. Zero a => a
zero
{ $sel:size:BufferCreateInfo :: Word64
Vk.size = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeBytes
, $sel:usage:BufferCreateInfo :: BufferUsageFlagBits
Vk.usage = BufferUsageFlagBits
usage
, $sel:sharingMode:BufferCreateInfo :: SharingMode
Vk.sharingMode = SharingMode
Vk.SHARING_MODE_EXCLUSIVE
}
flags :: MemoryPropertyFlagBits
flags =
MemoryPropertyFlagBits
Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT MemoryPropertyFlagBits
-> MemoryPropertyFlagBits -> MemoryPropertyFlagBits
forall a. Bits a => a -> a -> a
.|.
MemoryPropertyFlagBits
Vk.MEMORY_PROPERTY_HOST_COHERENT_BIT
aci :: AllocationCreateInfo
aci = AllocationCreateInfo
forall a. Zero a => a
zero
{ $sel:flags:AllocationCreateInfo :: AllocationCreateFlags
VMA.flags = AllocationCreateFlags
VMA.ALLOCATION_CREATE_MAPPED_BIT
, $sel:usage:AllocationCreateInfo :: MemoryUsage
VMA.usage = MemoryUsage
VMA.MEMORY_USAGE_GPU_ONLY
, $sel:requiredFlags:AllocationCreateInfo :: MemoryPropertyFlagBits
VMA.requiredFlags = MemoryPropertyFlagBits
flags
, $sel:preferredFlags:AllocationCreateInfo :: MemoryPropertyFlagBits
VMA.preferredFlags = MemoryPropertyFlagBits
Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
}
createStaged
:: forall a env m
. ( Storable a
, MonadVulkan env m
)
=> Maybe Text
-> Queues Vk.CommandPool
-> Vk.BufferUsageFlagBits
-> Int
-> VectorS.Vector a
-> m (Allocated 'Staged a)
createStaged :: forall a env (m :: * -> *).
(Storable a, MonadVulkan env m) =>
Maybe Text
-> Queues CommandPool
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (Allocated 'Staged a)
createStaged Maybe Text
aLabel Queues CommandPool
commandQueues BufferUsageFlagBits
usage Int
initialSize Vector a
xs = do
Allocator
allocator <- (env -> Allocator) -> m Allocator
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Allocator
forall a. HasVulkan a => a -> Allocator
getAllocator
(Buffer
aBuffer, Allocation
aAllocation, AllocationInfo
aAllocationInfo) <- Allocator
-> BufferCreateInfo '[]
-> AllocationCreateInfo
-> m (Buffer, Allocation, AllocationInfo)
forall (a :: [*]) (io :: * -> *).
(Extendss BufferCreateInfo a, PokeChain a, MonadIO io) =>
Allocator
-> BufferCreateInfo a
-> AllocationCreateInfo
-> io (Buffer, Allocation, AllocationInfo)
VMA.createBuffer Allocator
allocator BufferCreateInfo '[]
bci AllocationCreateInfo
aci
(Text -> m ()) -> Maybe Text -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Buffer -> Text -> m ()
forall env (m :: * -> *) a.
(MonadVulkan env m, HasObjectType a) =>
a -> Text -> m ()
Named.object Buffer
aBuffer) Maybe Text
aLabel
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
Allocator
-> BufferCreateInfo '[]
-> AllocationCreateInfo
-> (m (Buffer, Allocation, AllocationInfo)
-> ((Buffer, Allocation, AllocationInfo) -> m ())
-> ((Buffer, Allocation, AllocationInfo) -> m ())
-> m ())
-> ((Buffer, Allocation, AllocationInfo) -> m ())
-> m ()
forall (a :: [*]) (io :: * -> *) r.
(Extendss BufferCreateInfo a, PokeChain a, MonadIO io) =>
Allocator
-> BufferCreateInfo a
-> AllocationCreateInfo
-> (io (Buffer, Allocation, AllocationInfo)
-> ((Buffer, Allocation, AllocationInfo) -> io ()) -> r)
-> r
VMA.withBuffer Allocator
allocator BufferCreateInfo '[]
stageCI AllocationCreateInfo
stageAI m (Buffer, Allocation, AllocationInfo)
-> ((Buffer, Allocation, AllocationInfo) -> m ())
-> ((Buffer, Allocation, AllocationInfo) -> m ())
-> m ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket \(Buffer
staging, Allocation
_stage, AllocationInfo
stageInfo) ->
if AllocationInfo -> Ptr ()
VMA.mappedData AllocationInfo
stageInfo Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
Foreign.nullPtr then
String -> m ()
forall a. HasCallStack => String -> a
error String
"TODO: recover from unmapped data and flush manually"
else do
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Vector a -> (Ptr a -> IO ()) -> IO ()
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
VectorS.unsafeWith Vector a
xs \Ptr a
src ->
Ptr a -> Ptr a -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyBytes (Ptr () -> Ptr a
forall a b. Ptr a -> Ptr b
Foreign.castPtr (Ptr () -> Ptr a) -> Ptr () -> Ptr a
forall a b. (a -> b) -> a -> b
$ AllocationInfo -> Ptr ()
VMA.mappedData AllocationInfo
stageInfo) Ptr a
src Int
lenBytes
env
context <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
env -> Queues CommandPool -> Buffer -> Buffer -> Word64 -> m ()
forall (io :: * -> *) context.
(MonadUnliftIO io, HasVulkan context) =>
context
-> Queues CommandPool -> Buffer -> Buffer -> Word64 -> io ()
copyBuffer_ env
context Queues CommandPool
commandQueues Buffer
aBuffer Buffer
staging (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeBytes)
pure Allocated
{ $sel:aCapacity:Allocated :: Int
aCapacity = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
initialSize Int
len
, $sel:aUsed:Allocated :: Word32
aUsed = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
, $sel:aUsage:Allocated :: BufferUsageFlagBits
aUsage = BufferUsageFlagBits
usage
, $sel:aLabel:Allocated :: Maybe Text
aLabel = Maybe Text
forall a. Maybe a
Nothing
, AllocationInfo
Allocation
Buffer
$sel:aBuffer:Allocated :: Buffer
$sel:aAllocation:Allocated :: Allocation
$sel:aAllocationInfo:Allocated :: AllocationInfo
aBuffer :: Buffer
aAllocation :: Allocation
aAllocationInfo :: AllocationInfo
..
}
where
len :: Int
len = Vector a -> Int
forall a. Storable a => Vector a -> Int
VectorS.length Vector a
xs
lenBytes :: Int
lenBytes = a -> Int
forall a. Storable a => a -> Int
Foreign.sizeOf (a
forall a. HasCallStack => a
undefined :: a) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
len
sizeBytes :: Int
sizeBytes = a -> Int
forall a. Storable a => a -> Int
Foreign.sizeOf (a
forall a. HasCallStack => a
undefined :: a) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
initialSize Int
len
bci :: BufferCreateInfo '[]
bci = BufferCreateInfo '[]
forall a. Zero a => a
zero
{ $sel:size:BufferCreateInfo :: Word64
Vk.size = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeBytes
, $sel:usage:BufferCreateInfo :: BufferUsageFlagBits
Vk.usage = BufferUsageFlagBits
Vk.BUFFER_USAGE_TRANSFER_DST_BIT BufferUsageFlagBits -> BufferUsageFlagBits -> BufferUsageFlagBits
forall a. Bits a => a -> a -> a
.|. BufferUsageFlagBits
usage
, $sel:sharingMode:BufferCreateInfo :: SharingMode
Vk.sharingMode = SharingMode
Vk.SHARING_MODE_EXCLUSIVE
}
aci :: AllocationCreateInfo
aci = AllocationCreateInfo
forall a. Zero a => a
zero
{ $sel:usage:AllocationCreateInfo :: MemoryUsage
VMA.usage = MemoryUsage
VMA.MEMORY_USAGE_GPU_ONLY
, $sel:requiredFlags:AllocationCreateInfo :: MemoryPropertyFlagBits
VMA.requiredFlags = MemoryPropertyFlagBits
Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
}
stageCI :: BufferCreateInfo '[]
stageCI = BufferCreateInfo '[]
forall a. Zero a => a
zero
{ $sel:size:BufferCreateInfo :: Word64
Vk.size = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeBytes
, $sel:usage:BufferCreateInfo :: BufferUsageFlagBits
Vk.usage = BufferUsageFlagBits
Vk.BUFFER_USAGE_TRANSFER_SRC_BIT
, $sel:sharingMode:BufferCreateInfo :: SharingMode
Vk.sharingMode = SharingMode
Vk.SHARING_MODE_EXCLUSIVE
}
stageAI :: AllocationCreateInfo
stageAI = AllocationCreateInfo
forall a. Zero a => a
zero
{ $sel:flags:AllocationCreateInfo :: AllocationCreateFlags
VMA.flags = AllocationCreateFlags
VMA.ALLOCATION_CREATE_MAPPED_BIT
, $sel:usage:AllocationCreateInfo :: MemoryUsage
VMA.usage = MemoryUsage
VMA.MEMORY_USAGE_CPU_TO_GPU
, $sel:requiredFlags:AllocationCreateInfo :: MemoryPropertyFlagBits
VMA.requiredFlags = MemoryPropertyFlagBits
Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT
}
register
:: ( MonadVulkan env m
, MonadResource m
)
=> Allocated stage a
-> m Resource.ReleaseKey
register :: forall {k} env (m :: * -> *) (stage :: Store) (a :: k).
(MonadVulkan env m, MonadResource m) =>
Allocated stage a -> m ReleaseKey
register Allocated{Buffer
$sel:aBuffer:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> Buffer
aBuffer :: Buffer
aBuffer, Allocation
$sel:aAllocation:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> Allocation
aAllocation :: Allocation
aAllocation} = do
Allocator
allocator <- (env -> Allocator) -> m Allocator
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Allocator
forall a. HasVulkan a => a -> Allocator
getAllocator
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
$ Allocator -> Buffer -> Allocation -> IO ()
forall (io :: * -> *).
MonadIO io =>
Allocator -> Buffer -> Allocation -> io ()
VMA.destroyBuffer Allocator
allocator Buffer
aBuffer Allocation
aAllocation
destroy
:: (MonadUnliftIO io, HasVulkan context)
=> context
-> Allocated s a
-> io ()
destroy :: forall {k} (io :: * -> *) context (s :: Store) (a :: k).
(MonadUnliftIO io, HasVulkan context) =>
context -> Allocated s a -> io ()
destroy context
context Allocated s a
a =
Allocator -> Buffer -> Allocation -> io ()
forall (io :: * -> *).
MonadIO io =>
Allocator -> Buffer -> Allocation -> io ()
VMA.destroyBuffer (context -> Allocator
forall a. HasVulkan a => a -> Allocator
getAllocator context
context) (Allocated s a -> Buffer
forall {k} (s :: Store) (a :: k). Allocated s a -> Buffer
aBuffer Allocated s a
a) (Allocated s a -> Allocation
forall {k} (s :: Store) (a :: k). Allocated s a -> Allocation
aAllocation Allocated s a
a)
peekCoherent
:: ( MonadIO m
, Storable a
)
=> Word32
-> Allocated 'Coherent a
-> m (Maybe a)
peekCoherent :: forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Word32 -> Allocated 'Coherent a -> m (Maybe a)
peekCoherent Word32
ix Allocated{Int
Maybe Text
Word32
AllocationInfo
Allocation
BufferUsageFlagBits
Buffer
$sel:aBuffer:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> Buffer
$sel:aAllocation:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> Allocation
$sel:aAllocationInfo:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> AllocationInfo
$sel:aCapacity:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> Int
$sel:aUsed:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> Word32
$sel:aUsage:Allocated :: forall {k} (s :: Store) (a :: k).
Allocated s a -> BufferUsageFlagBits
$sel:aLabel:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> Maybe Text
aBuffer :: Buffer
aAllocation :: Allocation
aAllocationInfo :: AllocationInfo
aCapacity :: Int
aUsed :: Word32
aUsage :: BufferUsageFlagBits
aLabel :: Maybe Text
..} =
case AllocationInfo -> Ptr ()
VMA.mappedData AllocationInfo
aAllocationInfo of
Ptr ()
_ | Word32
ix Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1 Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
aUsed ->
Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
Ptr ()
ptr | Ptr ()
ptr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
Foreign.nullPtr ->
Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
Ptr ()
ptr ->
IO (Maybe a) -> m (Maybe a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe a) -> m (Maybe a))
-> (IO a -> IO (Maybe a)) -> IO a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (IO a -> m (Maybe a)) -> IO a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$
Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
Foreign.peekElemOff (Ptr () -> Ptr a
forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr ()
ptr) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ix)
{-# INLINE pokeCoherent #-}
pokeCoherent
:: ( MonadVulkan env m
, Storable a
)
=> Allocated 'Coherent a
-> Word32
-> a
-> m ()
pokeCoherent :: forall env (m :: * -> *) a.
(MonadVulkan env m, Storable a) =>
Allocated 'Coherent a -> Word32 -> a -> m ()
pokeCoherent Allocated{Int
Maybe Text
Word32
AllocationInfo
Allocation
BufferUsageFlagBits
Buffer
$sel:aBuffer:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> Buffer
$sel:aAllocation:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> Allocation
$sel:aAllocationInfo:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> AllocationInfo
$sel:aCapacity:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> Int
$sel:aUsed:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> Word32
$sel:aUsage:Allocated :: forall {k} (s :: Store) (a :: k).
Allocated s a -> BufferUsageFlagBits
$sel:aLabel:Allocated :: forall {k} (s :: Store) (a :: k). Allocated s a -> Maybe Text
aBuffer :: Buffer
aAllocation :: Allocation
aAllocationInfo :: AllocationInfo
aCapacity :: Int
aUsed :: Word32
aUsage :: BufferUsageFlagBits
aLabel :: Maybe Text
..} Word32
ix a
new =
case AllocationInfo -> Ptr ()
VMA.mappedData AllocationInfo
aAllocationInfo of
Ptr ()
_ | Word32
ix Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1 Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
aUsed ->
() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Ptr ()
ptr | Ptr ()
ptr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
Foreign.nullPtr ->
() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Ptr ()
ptr ->
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
Ptr a -> Int -> a -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
Foreign.pokeElemOff
(Ptr () -> Ptr a
forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr ()
ptr)
(Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ix)
a
new
updateCoherent
:: ( MonadUnliftIO io
, Foreign.Storable a
)
=> VectorS.Vector a
-> Allocated 'Coherent a
-> io (Allocated 'Coherent a)
updateCoherent :: forall (io :: * -> *) a.
(MonadUnliftIO io, Storable a) =>
Vector a -> Allocated 'Coherent a -> io (Allocated 'Coherent a)
updateCoherent Vector a
xs Allocated 'Coherent a
old = do
IO () -> io ()
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> io ()) -> IO () -> io ()
forall a b. (a -> b) -> a -> b
$ Vector a -> (Ptr a -> IO ()) -> IO ()
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
VectorS.unsafeWith Vector a
xs \Ptr a
src ->
Ptr a -> Ptr a -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyBytes Ptr a
dst Ptr a
src Int
lenBytes
pure Allocated 'Coherent a
old
{ $sel:aUsed:Allocated :: Word32
aUsed = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
}
where
dst :: Ptr a
dst = Ptr () -> Ptr a
forall a b. Ptr a -> Ptr b
Foreign.castPtr (Ptr () -> Ptr a) -> Ptr () -> Ptr a
forall a b. (a -> b) -> a -> b
$ AllocationInfo -> Ptr ()
VMA.mappedData (Allocated 'Coherent a -> AllocationInfo
forall {k} (s :: Store) (a :: k). Allocated s a -> AllocationInfo
aAllocationInfo Allocated 'Coherent a
old)
len :: Int
len = Vector a -> Int
forall a. Storable a => Vector a -> Int
VectorS.length Vector a
xs
lenBytes :: Int
lenBytes = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
forall a. Storable a => a -> Int
Foreign.sizeOf (Vector a -> a
forall a. Storable a => Vector a -> a
VectorS.head Vector a
xs)
{-# INLINE updateCoherentResize_ #-}
updateCoherentResize_
:: ( MonadVulkan env m
, Storable a
)
=> Allocated 'Coherent a
-> VectorS.Vector a
-> m (Allocated 'Coherent a)
updateCoherentResize_ :: forall env (m :: * -> *) a.
(MonadVulkan env m, Storable a) =>
Allocated 'Coherent a -> Vector a -> m (Allocated 'Coherent a)
updateCoherentResize_ Allocated 'Coherent a
old Vector a
xs =
if Int
newSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
oldSize then
Vector a -> Allocated 'Coherent a -> m (Allocated 'Coherent a)
forall (io :: * -> *) a.
(MonadUnliftIO io, Storable a) =>
Vector a -> Allocated 'Coherent a -> io (Allocated 'Coherent a)
updateCoherent Vector a
xs Allocated 'Coherent a
old
else do
env
ctx <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
env -> Allocated 'Coherent a -> m ()
forall {k} (io :: * -> *) context (s :: Store) (a :: k).
(MonadUnliftIO io, HasVulkan context) =>
context -> Allocated s a -> io ()
destroy env
ctx Allocated 'Coherent a
old
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (Allocated 'Coherent a)
forall a env (m :: * -> *).
(MonadVulkan env m, Storable a) =>
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (Allocated 'Coherent a)
createCoherent (Allocated 'Coherent a -> Maybe Text
forall {k} (s :: Store) (a :: k). Allocated s a -> Maybe Text
aLabel Allocated 'Coherent a
old) (Allocated 'Coherent a -> BufferUsageFlagBits
forall {k} (s :: Store) (a :: k).
Allocated s a -> BufferUsageFlagBits
aUsage Allocated 'Coherent a
old) Int
newSize Vector a
xs
where
oldSize :: Int
oldSize = Allocated 'Coherent a -> Int
forall {k} (s :: Store) (a :: k). Allocated s a -> Int
aCapacity Allocated 'Coherent a
old
newSize :: Int
newSize = Vector a -> Int
forall a. Storable a => Vector a -> Int
VectorS.length Vector a
xs
copyBuffer_
:: ( MonadUnliftIO io
, HasVulkan context
)
=> context
-> Queues Vk.CommandPool
-> ("dstBuffer" ::: Vk.Buffer)
-> ("srcBuffer" ::: Vk.Buffer)
-> Vk.DeviceSize
-> io ()
copyBuffer_ :: forall (io :: * -> *) context.
(MonadUnliftIO io, HasVulkan context) =>
context
-> Queues CommandPool -> Buffer -> Buffer -> Word64 -> io ()
copyBuffer_ context
context Queues CommandPool
commandQueues Buffer
dst Buffer
src Word64
sizeBytes =
context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> io ())
-> io ()
forall context (m :: * -> *).
(HasVulkan context, MonadUnliftIO m) =>
context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
oneshot_ context
context Queues CommandPool
commandQueues Queues a -> a
forall a. Queues a -> a
qTransfer \CommandBuffer
cmd ->
CommandBuffer
-> Buffer -> Buffer -> ("regions" ::: Vector BufferCopy) -> io ()
forall (io :: * -> *).
MonadIO io =>
CommandBuffer
-> Buffer -> Buffer -> ("regions" ::: Vector BufferCopy) -> io ()
Vk.cmdCopyBuffer CommandBuffer
cmd Buffer
src Buffer
dst
(BufferCopy -> "regions" ::: Vector BufferCopy
forall a. a -> Vector a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BufferCopy -> "regions" ::: Vector BufferCopy)
-> BufferCopy -> "regions" ::: Vector BufferCopy
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word64 -> BufferCopy
Vk.BufferCopy Word64
0 Word64
0 Word64
sizeBytes)
type ObserverCoherent a = Worker.ObserverIO (Allocated 'Coherent a)
newObserverCoherent
:: ( MonadVulkan env m
, Storable a
)
=> "label" ::: Text
-> Vk.BufferUsageFlagBits
-> Int
-> VectorS.Vector a
-> Resource.ResourceT m (ObserverCoherent a)
newObserverCoherent :: forall env (m :: * -> *) a.
(MonadVulkan env m, Storable a) =>
Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> ResourceT m (ObserverCoherent a)
newObserverCoherent Text
label BufferUsageFlagBits
usage Int
initialCapacity Vector a
initialData = do
Allocated 'Coherent a
initialBuffer <- Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> ResourceT m (Allocated 'Coherent a)
forall a env (m :: * -> *).
(MonadVulkan env m, Storable a) =>
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (Allocated 'Coherent a)
createCoherent (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
label) BufferUsageFlagBits
usage Int
initialCapacity Vector a
initialData
ObserverCoherent a
observer <- Allocated 'Coherent a -> ResourceT m (ObserverCoherent a)
forall (m :: * -> *) a. MonadIO m => a -> m (ObserverIO a)
Worker.newObserverIO Allocated 'Coherent a
initialBuffer
env
context <- ResourceT m env
forall r (m :: * -> *). MonadReader r m => m r
ask
ResourceT m ReleaseKey -> ResourceT m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ResourceT m ReleaseKey -> ResourceT m ())
-> ResourceT m ReleaseKey -> ResourceT m ()
forall a b. (a -> b) -> a -> b
$! IO () -> ResourceT m ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register do
Allocated 'Coherent a
currentBuffer <- ObserverCoherent a -> IO (Allocated 'Coherent a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
IORef (Versioned a) -> m a
Worker.readObservedIO ObserverCoherent a
observer
env -> Allocated 'Coherent a -> IO ()
forall {k} (io :: * -> *) context (s :: Store) (a :: k).
(MonadUnliftIO io, HasVulkan context) =>
context -> Allocated s a -> io ()
destroy env
context Allocated 'Coherent a
currentBuffer
pure ObserverCoherent a
observer
{-# INLINE observeCoherentResize_ #-}
observeCoherentResize_
:: ( MonadVulkan env m
, Worker.HasOutput source
, Worker.GetOutput source ~ VectorS.Vector output
, Storable output
)
=> source
-> ObserverCoherent output
-> m ()
observeCoherentResize_ :: forall env (m :: * -> *) source output.
(MonadVulkan env m, HasOutput source,
GetOutput source ~ Vector output, Storable output) =>
source -> ObserverCoherent output -> m ()
observeCoherentResize_ source
source ObserverCoherent output
observer = do
source
-> ObserverCoherent output
-> (Allocated 'Coherent output
-> GetOutput source -> m (Allocated 'Coherent output))
-> m ()
forall (m :: * -> *) output a.
(MonadUnliftIO m, HasOutput output) =>
output -> ObserverIO a -> (a -> GetOutput output -> m a) -> m ()
Worker.observeIO_ source
source ObserverCoherent output
observer Allocated 'Coherent output
-> Vector output -> m (Allocated 'Coherent output)
Allocated 'Coherent output
-> GetOutput source -> m (Allocated 'Coherent output)
forall env (m :: * -> *) a.
(MonadVulkan env m, Storable a) =>
Allocated 'Coherent a -> Vector a -> m (Allocated 'Coherent a)
updateCoherentResize_
{-# INLINE observeCoherentSingle #-}
observeCoherentSingle
:: ( MonadVulkan env m
, Worker.HasOutput source
, Worker.GetOutput source ~ output
, Storable output
)
=> source
-> ObserverCoherent output
-> m ()
observeCoherentSingle :: forall env (m :: * -> *) source output.
(MonadVulkan env m, HasOutput source, GetOutput source ~ output,
Storable output) =>
source -> ObserverCoherent output -> m ()
observeCoherentSingle source
source ObserverCoherent output
observer =
source
-> ObserverCoherent output
-> (Allocated 'Coherent output
-> GetOutput source -> m (Allocated 'Coherent output))
-> m ()
forall (m :: * -> *) output a.
(MonadUnliftIO m, HasOutput output) =>
output -> ObserverIO a -> (a -> GetOutput output -> m a) -> m ()
Worker.observeIO_ source
source ObserverCoherent output
observer \Allocated 'Coherent output
a GetOutput source
b ->
Allocated 'Coherent output -> Word32 -> output -> m ()
forall env (m :: * -> *) a.
(MonadVulkan env m, Storable a) =>
Allocated 'Coherent a -> Word32 -> a -> m ()
pokeCoherent Allocated 'Coherent output
a Word32
0 output
GetOutput source
b m ()
-> Allocated 'Coherent output -> m (Allocated 'Coherent output)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Allocated 'Coherent output
a