module Resource.CommandBuffer
( allocatePools
, withPools
, oneshot_
) where
import RIO
import Data.Vector qualified as Vector
import UnliftIO.Resource (MonadResource)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.CStruct.Extends (SomeStruct(..))
import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..))
import Vulkan.Zero (zero)
import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, Queues(..))
allocatePools
:: (HasVulkan context, Resource.MonadResource m)
=> context
-> m (Resource.ReleaseKey, Queues Vk.CommandPool)
allocatePools :: context -> m (ReleaseKey, Queues CommandPool)
allocatePools context
context = do
Queues (ReleaseKey, CommandPool)
bootstrapQueues <- Queues (QueueFamilyIndex, Queue)
-> ((QueueFamilyIndex, Queue) -> m (ReleaseKey, CommandPool))
-> m (Queues (ReleaseKey, CommandPool))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (context -> Queues (QueueFamilyIndex, Queue)
forall a. HasVulkan a => a -> Queues (QueueFamilyIndex, Queue)
getQueues context
context) \(QueueFamilyIndex Word32
ix, Queue
_queue) -> do
let
commandPoolCI :: CommandPoolCreateInfo
commandPoolCI = CommandPoolCreateInfo :: CommandPoolCreateFlags -> Word32 -> CommandPoolCreateInfo
Vk.CommandPoolCreateInfo
{ $sel:flags:CommandPoolCreateInfo :: CommandPoolCreateFlags
flags = CommandPoolCreateFlags
forall a. Zero a => a
zero
, $sel:queueFamilyIndex:CommandPoolCreateInfo :: Word32
queueFamilyIndex = Word32
ix
}
Device
-> CommandPoolCreateInfo
-> Maybe AllocationCallbacks
-> (IO CommandPool
-> (CommandPool -> IO ()) -> m (ReleaseKey, CommandPool))
-> m (ReleaseKey, CommandPool)
forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandPoolCreateInfo
-> Maybe AllocationCallbacks
-> (io CommandPool -> (CommandPool -> io ()) -> r)
-> r
Vk.withCommandPool (context -> Device
forall a. HasVulkan a => a -> Device
getDevice context
context) CommandPoolCreateInfo
commandPoolCI Maybe AllocationCallbacks
forall a. Maybe a
Nothing IO CommandPool
-> (CommandPool -> IO ()) -> m (ReleaseKey, CommandPool)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
ReleaseKey
bqKey <- 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
$
((ReleaseKey, CommandPool) -> IO ())
-> Queues (ReleaseKey, CommandPool) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ReleaseKey -> IO ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release (ReleaseKey -> IO ())
-> ((ReleaseKey, CommandPool) -> ReleaseKey)
-> (ReleaseKey, CommandPool)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReleaseKey, CommandPool) -> ReleaseKey
forall a b. (a, b) -> a
fst) Queues (ReleaseKey, CommandPool)
bootstrapQueues
pure (ReleaseKey
bqKey, ((ReleaseKey, CommandPool) -> CommandPool)
-> Queues (ReleaseKey, CommandPool) -> Queues CommandPool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReleaseKey, CommandPool) -> CommandPool
forall a b. (a, b) -> b
snd Queues (ReleaseKey, CommandPool)
bootstrapQueues)
withPools
:: (MonadVulkan env m, MonadResource m)
=> (Queues Vk.CommandPool -> m a)
-> m a
withPools :: (Queues CommandPool -> m a) -> m a
withPools Queues CommandPool -> m a
action = do
env
context <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
m (ReleaseKey, Queues CommandPool)
-> ((ReleaseKey, Queues CommandPool) -> m ())
-> ((ReleaseKey, Queues CommandPool) -> m a)
-> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (env -> m (ReleaseKey, Queues CommandPool)
forall context (m :: * -> *).
(HasVulkan context, MonadResource m) =>
context -> m (ReleaseKey, Queues CommandPool)
allocatePools env
context) (ReleaseKey -> m ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release (ReleaseKey -> m ())
-> ((ReleaseKey, Queues CommandPool) -> ReleaseKey)
-> (ReleaseKey, Queues CommandPool)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReleaseKey, Queues CommandPool) -> ReleaseKey
forall a b. (a, b) -> a
fst) (Queues CommandPool -> m a
action (Queues CommandPool -> m a)
-> ((ReleaseKey, Queues CommandPool) -> Queues CommandPool)
-> (ReleaseKey, Queues CommandPool)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReleaseKey, Queues CommandPool) -> Queues CommandPool
forall a b. (a, b) -> b
snd)
oneshot_
:: (HasVulkan context, MonadUnliftIO m)
=> context
-> Queues Vk.CommandPool
-> (forall a . Queues a -> a)
-> (Vk.CommandBuffer -> m ())
-> m ()
oneshot_ :: context
-> Queues CommandPool
-> (forall a. Queues a -> a)
-> (CommandBuffer -> m ())
-> m ()
oneshot_ context
context Queues CommandPool
pools forall a. Queues a -> a
pickQueue CommandBuffer -> m ()
action =
Device
-> CommandBufferAllocateInfo
-> (m (Vector CommandBuffer)
-> (Vector CommandBuffer -> m ())
-> (Vector CommandBuffer -> m ())
-> m ())
-> (Vector CommandBuffer -> m ())
-> m ()
forall (io :: * -> *) r.
MonadIO io =>
Device
-> CommandBufferAllocateInfo
-> (io (Vector CommandBuffer)
-> (Vector CommandBuffer -> io ()) -> r)
-> r
Vk.withCommandBuffers Device
device CommandBufferAllocateInfo
commandBufferAllocateInfo m (Vector CommandBuffer)
-> (Vector CommandBuffer -> m ())
-> (Vector CommandBuffer -> m ())
-> m ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket \case
(Vector CommandBuffer -> [CommandBuffer]
forall a. Vector a -> [a]
Vector.toList -> [CommandBuffer
buf]) -> do
let
oneTime :: Vk.CommandBufferBeginInfo '[]
oneTime :: CommandBufferBeginInfo '[]
oneTime = CommandBufferBeginInfo '[]
forall a. Zero a => a
zero
{ $sel:flags:CommandBufferBeginInfo :: CommandBufferUsageFlags
Vk.flags = CommandBufferUsageFlags
Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT
}
CommandBuffer -> CommandBufferBeginInfo '[] -> m () -> m ()
forall (a :: [*]) (io :: * -> *) r.
(Extendss CommandBufferBeginInfo a, PokeChain a, MonadIO io) =>
CommandBuffer -> CommandBufferBeginInfo a -> io r -> io r
Vk.useCommandBuffer CommandBuffer
buf CommandBufferBeginInfo '[]
oneTime (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ CommandBuffer -> m ()
action CommandBuffer
buf
Device
-> FenceCreateInfo '[]
-> Maybe AllocationCallbacks
-> (m Fence -> (Fence -> m ()) -> (Fence -> m ()) -> m ())
-> (Fence -> m ())
-> m ()
forall (a :: [*]) (io :: * -> *) r.
(Extendss FenceCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> FenceCreateInfo a
-> Maybe AllocationCallbacks
-> (io Fence -> (Fence -> io ()) -> r)
-> r
Vk.withFence Device
device FenceCreateInfo '[]
forall a. Zero a => a
zero Maybe AllocationCallbacks
forall a. Maybe a
Nothing m Fence -> (Fence -> m ()) -> (Fence -> m ()) -> m ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket \Fence
fence -> do
Queue
-> ("submits" ::: Vector (SomeStruct SubmitInfo)) -> Fence -> m ()
forall (io :: * -> *).
MonadIO io =>
Queue
-> ("submits" ::: Vector (SomeStruct SubmitInfo)) -> Fence -> io ()
Vk.queueSubmit Queue
queue (CommandBuffer -> "submits" ::: Vector (SomeStruct SubmitInfo)
wrap CommandBuffer
buf) Fence
fence
Device
-> ("fences" ::: Vector Fence)
-> ("waitAll" ::: Bool)
-> ("timeout" ::: Word64)
-> m Result
forall (io :: * -> *).
MonadIO io =>
Device
-> ("fences" ::: Vector Fence)
-> ("waitAll" ::: Bool)
-> ("timeout" ::: Word64)
-> io Result
Vk.waitForFences Device
device (Fence -> "fences" ::: Vector Fence
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fence
fence) "waitAll" ::: Bool
True "timeout" ::: Word64
forall a. Bounded a => a
maxBound m Result -> (Result -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Result
Vk.SUCCESS ->
() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Result
err ->
[Char] -> m ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"oneshot_ failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Result -> [Char]
forall a. Show a => a -> [Char]
show Result
err
Vector CommandBuffer
_ ->
[Char] -> m ()
forall a. HasCallStack => [Char] -> a
error [Char]
"assert: exactly the requested buffer was given"
where
device :: Device
device = context -> Device
forall a. HasVulkan a => a -> Device
getDevice context
context
queue :: Queue
queue = (QueueFamilyIndex, Queue) -> Queue
forall a b. (a, b) -> b
snd ((QueueFamilyIndex, Queue) -> Queue)
-> (Queues (QueueFamilyIndex, Queue) -> (QueueFamilyIndex, Queue))
-> Queues (QueueFamilyIndex, Queue)
-> Queue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Queues (QueueFamilyIndex, Queue) -> (QueueFamilyIndex, Queue)
forall a. Queues a -> a
pickQueue (Queues (QueueFamilyIndex, Queue) -> Queue)
-> Queues (QueueFamilyIndex, Queue) -> Queue
forall a b. (a -> b) -> a -> b
$ context -> Queues (QueueFamilyIndex, Queue)
forall a. HasVulkan a => a -> Queues (QueueFamilyIndex, Queue)
getQueues context
context
commandBufferAllocateInfo :: Vk.CommandBufferAllocateInfo
commandBufferAllocateInfo :: CommandBufferAllocateInfo
commandBufferAllocateInfo = CommandBufferAllocateInfo
forall a. Zero a => a
zero
{ $sel:commandPool:CommandBufferAllocateInfo :: CommandPool
Vk.commandPool = Queues CommandPool -> CommandPool
forall a. Queues a -> a
pickQueue Queues CommandPool
pools
, $sel:level:CommandBufferAllocateInfo :: CommandBufferLevel
Vk.level = CommandBufferLevel
Vk.COMMAND_BUFFER_LEVEL_PRIMARY
, $sel:commandBufferCount:CommandBufferAllocateInfo :: Word32
Vk.commandBufferCount = Word32
1
}
wrap :: CommandBuffer -> "submits" ::: Vector (SomeStruct SubmitInfo)
wrap CommandBuffer
buf = SomeStruct SubmitInfo
-> "submits" ::: Vector (SomeStruct SubmitInfo)
forall a. a -> Vector a
Vector.singleton (SomeStruct SubmitInfo
-> "submits" ::: Vector (SomeStruct SubmitInfo))
-> SomeStruct SubmitInfo
-> "submits" ::: Vector (SomeStruct SubmitInfo)
forall a b. (a -> b) -> a -> b
$ SubmitInfo '[] -> SomeStruct SubmitInfo
forall (a :: [*] -> *) (es :: [*]).
(Extendss a es, PokeChain es, Show (Chain es)) =>
a es -> SomeStruct a
SomeStruct SubmitInfo '[]
forall a. Zero a => a
zero
{ $sel:commandBuffers:SubmitInfo :: Vector (Ptr CommandBuffer_T)
Vk.commandBuffers =
Ptr CommandBuffer_T -> Vector (Ptr CommandBuffer_T)
forall a. a -> Vector a
Vector.singleton (CommandBuffer -> Ptr CommandBuffer_T
Vk.commandBufferHandle CommandBuffer
buf)
}