Skip to content

Commit af6ba9e

Browse files
dpwizdpwiz
authored
Add image support for vulkan backend (#126)
1 parent dc11fad commit af6ba9e

File tree

5 files changed

+245
-14
lines changed

5 files changed

+245
-14
lines changed

‎dear-imgui.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -350,3 +350,5 @@ executable vulkan
350350
^>= 3.9
351351
, vulkan-utils
352352
^>= 0.4.1
353+
, VulkanMemoryAllocator
354+
, JuicyPixels

‎examples/vulkan/Main.hs

Lines changed: 189 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,9 @@ import Control.Arrow
2424
import Control.Exception
2525
( throw )
2626
import Control.Monad
27-
( unless, void )
27+
( unless, void, when )
28+
import Data.Bits
29+
( (.|.) )
2830
import Data.Foldable
2931
( traverse_ )
3032
import Data.String
@@ -62,11 +64,13 @@ import qualified Data.Vector as Boxed
6264
( Vector )
6365
import qualified Data.Vector as Boxed.Vector
6466
( (!), head, singleton, unzip )
67+
import qualified Data.Vector.Storable as Storable.Vector
6568

6669
-- vulkan
6770
import qualified Vulkan
68-
import qualified Vulkan.Exception as Vulkan
69-
import qualified Vulkan.Zero as Vulkan
71+
import qualified Vulkan.Exception as Vulkan
72+
import qualified Vulkan.Zero as Vulkan
73+
import qualified VulkanMemoryAllocator as VMA
7074

7175
-- dear-imgui
7276
import Attachments
@@ -76,22 +80,48 @@ import qualified DearImGui as ImGui
7680
import qualified DearImGui.Vulkan as ImGui.Vulkan
7781
import qualified DearImGui.SDL as ImGui.SDL
7882
import qualified DearImGui.SDL.Vulkan as ImGui.SDL.Vulkan
83+
import Util (vmaVulkanFunctions)
84+
import Foreign (Ptr, castPtr, copyBytes, with, withForeignPtr, wordPtrToPtr)
85+
import qualified DearImGui.Raw as ImGui.Raw
86+
import UnliftIO (MonadUnliftIO)
87+
import qualified Vulkan.CStruct.Extends as Vulkan
88+
89+
import qualified Codec.Picture as Picture
7990

8091
--------------------------------------------------------------------------------
8192

8293
type Handler = LogMessage -> ResourceT IO ()
8394
deriving via ( ReaderT Handler (ResourceT IO) )
8495
instance MonadResource ( LoggingT LogMessage (ResourceT IO) )
8596

86-
gui :: MonadIO m => m ImGui.DrawData
87-
gui = do
97+
gui :: MonadUnliftIO m => (ImGui.Raw.ImVec2, Ptr ()) -> m ImGui.DrawData
98+
gui texture = do
8899
-- Prepare frame
89100
ImGui.Vulkan.vulkanNewFrame
90101
ImGui.SDL.sdl2NewFrame
91102
ImGui.newFrame
92103

93104
-- Run your windows
94105
ImGui.showDemoWindow
106+
ImGui.withWindowOpen "Vulkan demo" do
107+
clicked <- liftIO do
108+
with (fst texture) \sizePtr ->
109+
with (ImGui.Raw.ImVec2 0 0) \uv0Ptr ->
110+
with (ImGui.Raw.ImVec2 1 1) \uv1Ptr ->
111+
with (ImGui.Raw.ImVec4 1 1 1 1) \tintColPtr ->
112+
with (ImGui.Raw.ImVec4 1 1 1 1) \bgColPtr ->
113+
ImGui.Raw.imageButton
114+
(snd texture)
115+
sizePtr
116+
uv0Ptr
117+
uv1Ptr
118+
(-1)
119+
bgColPtr
120+
tintColPtr
121+
122+
when clicked $
123+
ImGui.text "clicky click!"
124+
95125

96126
-- Process ImGui state into draw commands
97127
ImGui.render
@@ -275,6 +305,80 @@ app = do
275305
logDebug "Allocating command buffers"
276306
commandBuffers <- snd <$> allocatePrimaryCommandBuffers device commandPool imageCount
277307

308+
logDebug "Allocating VMA"
309+
(_key, vma) <- VMA.withAllocator
310+
Vulkan.zero
311+
{ VMA.instance' = Vulkan.instanceHandle instance'
312+
, VMA.device = Vulkan.deviceHandle device
313+
, VMA.physicalDevice = Vulkan.physicalDeviceHandle physicalDevice
314+
, VMA.vulkanFunctions = Just $ vmaVulkanFunctions device instance'
315+
}
316+
ResourceT.allocate
317+
318+
logDebug "Loading image data"
319+
picture <- liftIO (Picture.readImage "Example.png") >>= either error (pure . Picture.convertRGBA8)
320+
321+
logDebug "Allocating image"
322+
let textureWidth = Picture.imageWidth picture
323+
let textureHeight = Picture.imageHeight picture
324+
325+
(_key, (image, _imageAllocation, _imageAllocationInfo)) <- VMA.withImage
326+
vma
327+
( Vulkan.zero
328+
{ Vulkan.imageType = Vulkan.IMAGE_TYPE_2D
329+
, Vulkan.mipLevels = 1
330+
, Vulkan.arrayLayers = 1
331+
, Vulkan.format = Vulkan.FORMAT_R8G8B8A8_SRGB
332+
, Vulkan.extent = Vulkan.Extent3D (fromIntegral textureWidth) (fromIntegral textureHeight) 1
333+
, Vulkan.tiling = Vulkan.IMAGE_TILING_OPTIMAL
334+
, Vulkan.initialLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED
335+
, Vulkan.usage = Vulkan.IMAGE_USAGE_SAMPLED_BIT .|. Vulkan.IMAGE_USAGE_TRANSFER_DST_BIT
336+
, Vulkan.sharingMode = Vulkan.SHARING_MODE_EXCLUSIVE
337+
, Vulkan.samples = Vulkan.SAMPLE_COUNT_1_BIT
338+
}
339+
)
340+
( Vulkan.zero
341+
{ VMA.flags = Vulkan.zero
342+
, VMA.usage = VMA.MEMORY_USAGE_GPU_ONLY
343+
, VMA.requiredFlags = Vulkan.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
344+
}
345+
)
346+
ResourceT.allocate
347+
348+
let (pictureF, pictureSize) = Storable.Vector.unsafeToForeignPtr0 (Picture.imageData picture)
349+
350+
let stageBufferCI = Vulkan.zero
351+
{ Vulkan.size = fromIntegral pictureSize
352+
, Vulkan.usage = Vulkan.BUFFER_USAGE_TRANSFER_SRC_BIT
353+
, Vulkan.sharingMode = Vulkan.SHARING_MODE_EXCLUSIVE
354+
}
355+
let stageAllocationCI = Vulkan.zero
356+
{ VMA.flags = VMA.ALLOCATION_CREATE_MAPPED_BIT
357+
, VMA.usage = VMA.MEMORY_USAGE_CPU_TO_GPU
358+
, VMA.requiredFlags = Vulkan.MEMORY_PROPERTY_HOST_VISIBLE_BIT
359+
}
360+
361+
(stageKey, (stage, stageAllocation, stageAllocationInfo)) <- VMA.withBuffer
362+
vma
363+
stageBufferCI
364+
stageAllocationCI
365+
ResourceT.allocate
366+
367+
liftIO $ withForeignPtr pictureF \srcPtr ->
368+
copyBytes (VMA.mappedData stageAllocationInfo) (castPtr srcPtr) pictureSize
369+
370+
VMA.flushAllocation vma stageAllocation 0 Vulkan.WHOLE_SIZE
371+
372+
logDebug "Allocating sampler"
373+
(_key, sampler) <- Vulkan.withSampler device Vulkan.zero Nothing ResourceT.allocate
374+
logDebug "Allocating image view"
375+
(_key, imageView) <- createImageView
376+
device
377+
image
378+
Vulkan.IMAGE_VIEW_TYPE_2D
379+
Vulkan.FORMAT_R8G8B8A8_SRGB
380+
Vulkan.IMAGE_ASPECT_COLOR_BIT
381+
278382
-------------------------------------------
279383
-- Initialise Dear ImGui.
280384

@@ -308,23 +412,96 @@ app = do
308412
logDebug "Creating fence"
309413
( fenceKey, fence ) <- createFence device
310414
logDebug "Allocating one-shot command buffer"
311-
( fontUploadCommandBufferKey, fontUploadCommandBuffer ) <-
415+
( oneshotCommandBufferKey, oneshotCommandBuffer ) <-
312416
second Boxed.Vector.head <$>
313417
allocatePrimaryCommandBuffers device commandPool 1
314418

315419
logDebug "Recording one-shot commands"
316-
beginCommandBuffer fontUploadCommandBuffer
317-
_ <- ImGui.Vulkan.vulkanCreateFontsTexture fontUploadCommandBuffer
318-
endCommandBuffer fontUploadCommandBuffer
420+
beginCommandBuffer oneshotCommandBuffer
421+
_ <- ImGui.Vulkan.vulkanCreateFontsTexture oneshotCommandBuffer
422+
423+
logDebug "Uploading texture"
424+
let textureSubresource = Vulkan.ImageSubresourceRange
425+
{ Vulkan.aspectMask = Vulkan.IMAGE_ASPECT_COLOR_BIT
426+
, Vulkan.baseMipLevel = 0
427+
, Vulkan.levelCount = 1
428+
, Vulkan.baseArrayLayer = 0
429+
, Vulkan.layerCount = 1
430+
}
431+
432+
let uploadBarrier = Vulkan.zero
433+
{ Vulkan.srcAccessMask = Vulkan.zero
434+
, Vulkan.dstAccessMask = Vulkan.ACCESS_TRANSFER_WRITE_BIT
435+
, Vulkan.oldLayout = Vulkan.IMAGE_LAYOUT_UNDEFINED
436+
, Vulkan.newLayout = Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
437+
, Vulkan.srcQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
438+
, Vulkan.dstQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
439+
, Vulkan.image = image
440+
, Vulkan.subresourceRange = textureSubresource
441+
} :: Vulkan.ImageMemoryBarrier '[]
442+
Vulkan.cmdPipelineBarrier
443+
oneshotCommandBuffer
444+
Vulkan.PIPELINE_STAGE_TOP_OF_PIPE_BIT
445+
Vulkan.PIPELINE_STAGE_TRANSFER_BIT
446+
Vulkan.zero
447+
mempty
448+
mempty
449+
(Boxed.Vector.singleton $ Vulkan.SomeStruct uploadBarrier)
450+
451+
Vulkan.cmdCopyBufferToImage oneshotCommandBuffer stage image Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL $
452+
Boxed.Vector.singleton Vulkan.BufferImageCopy
453+
{ Vulkan.bufferOffset = 0
454+
, Vulkan.bufferRowLength = Vulkan.zero
455+
, Vulkan.bufferImageHeight = Vulkan.zero
456+
, Vulkan.imageSubresource = Vulkan.ImageSubresourceLayers
457+
{ aspectMask = Vulkan.IMAGE_ASPECT_COLOR_BIT
458+
, mipLevel = 0
459+
, baseArrayLayer = 0
460+
, layerCount = 1
461+
}
462+
, Vulkan.imageOffset = Vulkan.zero
463+
, Vulkan.imageExtent = Vulkan.Extent3D
464+
{ width = fromIntegral textureWidth
465+
, height = fromIntegral textureHeight
466+
, depth = 1
467+
}
468+
}
469+
470+
logDebug "Transitioning texture"
471+
let transitionBarrier = Vulkan.zero
472+
{ Vulkan.srcAccessMask = Vulkan.ACCESS_TRANSFER_WRITE_BIT
473+
, Vulkan.dstAccessMask = Vulkan.ACCESS_SHADER_READ_BIT
474+
, Vulkan.oldLayout = Vulkan.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
475+
, Vulkan.newLayout = Vulkan.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
476+
, Vulkan.srcQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
477+
, Vulkan.dstQueueFamilyIndex = Vulkan.QUEUE_FAMILY_IGNORED
478+
, Vulkan.image = image
479+
, Vulkan.subresourceRange = textureSubresource
480+
} :: Vulkan.ImageMemoryBarrier '[]
481+
Vulkan.cmdPipelineBarrier
482+
oneshotCommandBuffer
483+
Vulkan.PIPELINE_STAGE_TRANSFER_BIT
484+
Vulkan.PIPELINE_STAGE_FRAGMENT_SHADER_BIT
485+
Vulkan.zero
486+
mempty
487+
mempty
488+
(Boxed.Vector.singleton $ Vulkan.SomeStruct transitionBarrier)
489+
490+
endCommandBuffer oneshotCommandBuffer
319491

320492
logDebug "Submitting one-shot commands"
321-
submitCommandBuffer queue fontUploadCommandBuffer [] [] ( Just fence )
493+
submitCommandBuffer queue oneshotCommandBuffer [] [] ( Just fence )
322494
waitForFences device ( WaitAll [ fence ] )
323495

324496
logDebug "Finished uploading font objects"
325497
logDebug "Cleaning up one-shot commands"
326498
ImGui.Vulkan.vulkanDestroyFontUploadObjects
327-
traverse_ ResourceT.release [ fenceKey, fontUploadCommandBufferKey ]
499+
traverse_ ResourceT.release [ fenceKey, oneshotCommandBufferKey, stageKey ]
500+
501+
logDebug "Adding imgui texture"
502+
Vulkan.DescriptorSet ds <- ImGui.Vulkan.vulkanAddTexture sampler imageView Vulkan.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL
503+
let textureSize = ImGui.Raw.ImVec2 (fromIntegral textureWidth) (fromIntegral textureHeight)
504+
let texture = (textureSize, wordPtrToPtr $ fromIntegral ds)
328505

329506
let
330507
mainLoop :: AppState m -> m ()
@@ -364,7 +541,7 @@ app = do
364541
beginCommandBuffer commandBuffer
365542
cmdBeginRenderPass commandBuffer imGuiRenderPass framebuffer clearValues swapchainExtent
366543

367-
drawData <- gui
544+
drawData <- gui texture
368545
ImGui.Vulkan.vulkanRenderDrawData drawData commandBuffer Nothing
369546

370547
cmdEndRenderPass commandBuffer

‎examples/vulkan/Util.hs

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,7 @@
11
{-# LANGUAGE BlockArguments #-}
2+
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE NamedFieldPuns #-}
4+
{-# LANGUAGE RecordWildCards #-}
25
{-# LANGUAGE ScopedTypeVariables #-}
36

47
module Util where
@@ -12,13 +15,27 @@ import Data.Functor.Identity
1215
( Identity(..) )
1316
import Data.Traversable
1417
( for )
18+
#if MIN_VERSION_VulkanMemoryAllocator(0,8,0)
19+
import Foreign
20+
( castFunPtr )
21+
#endif
1522

1623
-- transformers
1724
import Control.Monad.Trans.State.Strict
1825
( StateT(..), State, evalState )
1926
import Control.Monad.Trans.Writer.Strict
2027
( runWriter, tell )
2128

29+
-- vulkan
30+
import qualified Vulkan
31+
#if MIN_VERSION_VulkanMemoryAllocator(0,8,0)
32+
import qualified Vulkan.Dynamic as VkDynamic
33+
#endif
34+
import Vulkan.Zero (zero)
35+
36+
-- VulkanMemoryAllocator
37+
import qualified VulkanMemoryAllocator as VMA
38+
2239
---------------------------------------------------------------
2340

2441
iunzipWith
@@ -38,3 +55,19 @@ ifor i0 upd ta f = (`evalState` i0) . getCompose $ result
3855
where
3956
result :: Compose (State i) f (t b)
4057
result = for ta \ a -> ( coerce ( \ i -> ( f i a, upd i ) ) )
58+
59+
vmaVulkanFunctions
60+
:: Vulkan.Device
61+
-> Vulkan.Instance
62+
-> VMA.VulkanFunctions
63+
#if MIN_VERSION_VulkanMemoryAllocator(0,8,0)
64+
vmaVulkanFunctions Vulkan.Device{deviceCmds} Vulkan.Instance{instanceCmds} =
65+
zero
66+
{ VMA.vkGetInstanceProcAddr =
67+
castFunPtr $ VkDynamic.pVkGetInstanceProcAddr instanceCmds
68+
, VMA.vkGetDeviceProcAddr =
69+
castFunPtr $ VkDynamic.pVkGetDeviceProcAddr deviceCmds
70+
}
71+
#else
72+
vmaVulkanFunctions _device _instance = zero
73+
#endif

‎src/DearImGui/Vulkan.hs

Lines changed: 17 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,8 @@ module DearImGui.Vulkan
1919
, vulkanCreateFontsTexture
2020
, vulkanDestroyFontUploadObjects
2121
, vulkanSetMinImageCount
22+
23+
, vulkanAddTexture
2224
)
2325
where
2426

@@ -32,7 +34,7 @@ import Foreign.Marshal.Alloc
3234
import Foreign.Ptr
3335
( FunPtr, Ptr, freeHaskellFunPtr, nullPtr )
3436
import Foreign.Storable
35-
( Storable(poke) )
37+
( poke )
3638

3739
-- inline-c
3840
import qualified Language.C.Inline as C
@@ -92,7 +94,7 @@ withVulkan initInfo renderPass action =
9294
( \ ( _, initResult ) -> action initResult )
9395

9496
-- | Wraps @ImGui_ImplVulkan_Init@.
95-
--
97+
--
9698
-- Use 'vulkanShutdown' to clean up on shutdown.
9799
-- Prefer using 'withVulkan' when possible, as it automatically handles cleanup.
98100
vulkanInit :: MonadIO m => InitInfo -> Vulkan.RenderPass -> m (FunPtr (Vulkan.Result -> IO ()), Bool)
@@ -184,3 +186,16 @@ vulkanDestroyFontUploadObjects = liftIO do
184186
vulkanSetMinImageCount :: MonadIO m => Word32 -> m ()
185187
vulkanSetMinImageCount minImageCount = liftIO do
186188
[C.exp| void { ImGui_ImplVulkan_SetMinImageCount($(uint32_t minImageCount)); } |]
189+
190+
-- | Wraps @ImGui_ImplVulkan_AddTexture@.
191+
vulkanAddTexture :: MonadIO m => Vulkan.Sampler -> Vulkan.ImageView -> Vulkan.ImageLayout -> m Vulkan.DescriptorSet
192+
vulkanAddTexture sampler imageView imageLayout = liftIO do
193+
[C.block|
194+
VkDescriptorSet {
195+
return ImGui_ImplVulkan_AddTexture(
196+
$(VkSampler sampler),
197+
$(VkImageView imageView),
198+
$(VkImageLayout imageLayout)
199+
);
200+
}
201+
|]

‎src/DearImGui/Vulkan/Types.hs

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,10 @@ vulkanTypesTable = Map.fromList
3131
, ( C.TypeName "VkRenderPass" , [t| Vulkan.RenderPass |] )
3232
, ( C.TypeName "VkResult" , [t| Vulkan.Result |] )
3333
, ( C.TypeName "VkSampleCountFlagBits", [t| Vulkan.SampleCountFlagBits |] )
34+
, ( C.TypeName "VkSampler" , [t| Vulkan.Sampler |] )
35+
, ( C.TypeName "VkImageView" , [t| Vulkan.ImageView |] )
36+
, ( C.TypeName "VkImageLayout" , [t| Vulkan.ImageLayout |] )
37+
, ( C.TypeName "VkDescriptorSet" , [t| Vulkan.DescriptorSet |] )
3438
]
3539

3640
vulkanCtx :: C.Context

0 commit comments

Comments
 (0)