unit uMainForm; {$mode objfpc}{$H+} interface uses Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls, Vulkan, VulkanUtils; type ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// TCustomAllocHandler = class(TvkuAllocationHandler) protected function AllocateMemory(const aSize: VkSize; const aAlignment: VkSize; const aScope: TVkSystemAllocationScope): PVkVoid; override; function ReallocateMemory(const aOriginal: PVkVoid; const aSize: VkSize; const aAlignment: VkSize; const aScope: TVkSystemAllocationScope): PVkVoid; override; procedure FreeMemory(const aMemory: PVkVoid); override; end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// TMainForm = class(TForm) RenderPanel: TPanel; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private fGraphicsQueueFamilyIndex: VkUint32; fGraphicsQueueNodeIndex: VkUint32; fPresentQueueNodeIndex: VkUint32; fSurfaceFormat: TVkFormat; fSurfaceColorSpace: TVkColorSpaceKHR; fAllocHandler: TCustomAllocHandler; fDebugReporter: TvkuConsoleDebugReporter; fInstance: TvkuInstance; fPhyDevice: TvkuPhysicalDevice; fDevice: TvkuDevice; fQueue: TvkuQueue; fSurface: TvkuSurface; fSwapChain: TvkuSwapChain; fImageViews: array of TvkuImageView; fRenderPass: TvkuRenderPass; fFrameBuffers: array of TvkuFrameBuffer; fDescSetLayout: TvkuDescriptorSetLayout; fPipelineLayout: TvkuPipelineLayout; fVertexShader: TvkuShaderModule; fFragmentShader: TvkuShaderModule; fPipeline: TvkuGraphicsPipeline; fCommandPool: TvkuCommandPool; fCommandBuffer: TvkuCommandBuffer; end; var MainForm: TMainForm; implementation {$R *.lfm} {$I Vulkan.inc} ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// //TCustomAllocHandler//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// function TCustomAllocHandler.AllocateMemory(const aSize: VkSize; const aAlignment: VkSize; const aScope: TVkSystemAllocationScope): PVkVoid; begin result := inherited AllocateMemory(aSize, aAlignment, aScope); WriteLn(Format(' MEM - %d bytes of memory allocated at %p', [ aSize, result ])); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// function TCustomAllocHandler.ReallocateMemory(const aOriginal: PVkVoid; const aSize: VkSize; const aAlignment: VkSize; const aScope: TVkSystemAllocationScope): PVkVoid; var p: PVkVoid; begin p := aOriginal; result := inherited ReallocateMemory(aOriginal, aSize, aAlignment, aScope); WriteLn(Format(' MEM - %d bytes of memory (from %p) reallocated at %p', [ aSize, p, result ])); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TCustomAllocHandler.FreeMemory(const aMemory: PVkVoid); begin WriteLn(Format(' MEM - free memory at %p', [ aMemory ])); inherited FreeMemory(aMemory); end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// //TMainForm////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TMainForm.FormCreate(Sender: TObject); var PhyDevices: TVkPhysicalDeviceArr; InstanceFactory: TvkuInstanceFactory; DeviceFactory: TvkuDeviceFactory; SurfaceFactory: TvkuSurfaceFactory; CommandPoolFactory: TvkuCommandPoolFactory; SwapChainFactory: TvkuSwapChainFactory; ImageViewFactory: TvkuImageViewFactory; RenderPassFactory: TvkuRenderPassFactory; FrameBufferFactory: TvkuFrameBufferFactory; DescSetLayoutFactory: TvkuDescriptorSetLayoutFactory; PipelineLayoutFactory: TvkuPipelineLayoutFactory; ShaderModuleFactory: TvkuShaderModuleFactory; PipelineFactory: TvkuGraphicsPipelineFactory; QueueFamProps: TVkQueueFamilyPropertiesArr; DepthFormat: TVkFormat; f: TVkFormat; i: Integer; SrfFormats: TVkSurfaceFormatArr; SurfaceCapabilities: TVkSurfaceCapabilitiesKHR; PresentModes: TVkPresentModeArr; pm: TVkPresentModeKHR; Images: TVkImageArr; ComponentMapping: TVkComponentMapping; begin fAllocHandler := TCustomAllocHandler.Create; ////////////////////////////////////////////////////////////////////////////// WriteLn('create instance: '); InstanceFactory := TvkuInstanceFactory.Create; try InstanceFactory.AllocHandler := fAllocHandler; InstanceFactory.EnabledExtensionNames.Add(VK_KHR_SURFACE_EXTENSION_NAME); InstanceFactory.EnabledExtensionNames.Add(VK_EXT_DEBUG_REPORT_EXTENSION_NAME); InstanceFactory.EnabledExtensionNames.Add(TvkuSurface.GetPlatformSurfaceExtensionName); fInstance := InstanceFactory.CreateInstance; WriteLn(' handle: ', PtrUInt(fInstance.Handle)); WriteLn(' done'); finally FreeAndNil(InstanceFactory); end; fDebugReporter := TvkuConsoleDebugReporter.Create(fInstance.InstanceCommands, fAllocHandler); ////////////////////////////////////////////////////////////////////////////// WriteLn('find suitable physical device'); PhyDevices := fInstance.GetPhysicalDevices; if (Length(PhyDevices) <= 0) then raise TvkuException.Create('unable to get physical device'); fPhyDevice := TvkuPhysicalDevice.Create(PhyDevices[0], fInstance.InstanceCommands); WriteLn(' handle: ', PtrUInt(fPhyDevice.Handle)); Write(' find suitable graphics queue index... '); QueueFamProps := fPhyDevice.GetQueueFamilyProperties; fGraphicsQueueFamilyIndex := high(fGraphicsQueueFamilyIndex); for i := low(QueueFamProps) to high(QueueFamProps) do begin if (VK_QUEUE_GRAPHICS_BIT in QueueFamProps[i].queueFlags) then begin fGraphicsQueueFamilyIndex := i; WriteLn(fGraphicsQueueFamilyIndex); break; end; end; if (fGraphicsQueueFamilyIndex = high(fGraphicsQueueFamilyIndex)) then raise TvkuException.Create('unable to find graphics queue index'); Write(' find suitable depth format... '); f := VK_FORMAT_UNDEFINED; for f in [ VK_FORMAT_D24_UNORM_S8_UINT, VK_FORMAT_D16_UNORM_S8_UINT, VK_FORMAT_D16_UNORM ] do begin if (VK_FORMAT_FEATURE_DEPTH_STENCIL_ATTACHMENT_BIT in fPhyDevice.GetFormatProperties(f).optimalTilingFeatures) then begin DepthFormat := f; break; end; end; WriteLn(DepthFormat); WriteLn(' done'); ////////////////////////////////////////////////////////////////////////////// WriteLn('create device'); DeviceFactory := TvkuDeviceFactory.Create(fInstance); try DeviceFactory.AllocHandler := fAllocHandler; DeviceFactory.EnabledExtensions.Add('VK_KHR_swapchain'); DeviceFactory.QueueCreateInfos.Length := 1; with DeviceFactory.QueueCreateInfos[0] do begin Flags := 0; QueueFamilyIndex := fGraphicsQueueFamilyIndex; QueuePriorities.Length := 1; QueuePriorities[0] := 1.0; end; fDevice := DeviceFactory.CreateDevice(fPhyDevice.Handle); WriteLn(' handle: ', PtrUInt(fDevice.Handle)); WriteLn(' done'); finally FreeAndNil(DeviceFactory); end; ////////////////////////////////////////////////////////////////////////////// WriteLn('find suitable queue'); fQueue := TvkuQueue.Create(fDevice.GetQueue(fGraphicsQueueFamilyIndex, 0), fDevice.DeviceCommands); WriteLn(' handle: ', PtrUInt(fQueue.Handle)); WriteLn(' done'); ////////////////////////////////////////////////////////////////////////////// WriteLn('create surface: '); SurfaceFactory := TvkuSurfaceFactory.Create(fInstance); try SurfaceFactory.AllocHandler := fAllocHandler; SurfaceFactory.WinControl := RenderPanel; fSurface := SurfaceFactory.CreateSurface; WriteLn(' handle: ', PtrUInt(fSurface.Handle)); WriteLn(' find suitable graphics and present queue node index'); fGraphicsQueueNodeIndex := high(fGraphicsQueueNodeIndex); fPresentQueueNodeIndex := high(fPresentQueueNodeIndex); QueueFamProps := fPhyDevice.GetQueueFamilyProperties; for i := low(QueueFamProps) to high(QueueFamProps) do begin if (VK_QUEUE_GRAPHICS_BIT in QueueFamProps[i].queueFlags) then fGraphicsQueueNodeIndex := i; if fPhyDevice.GetSurfaceSupport(i, fSurface.Handle) then begin fGraphicsQueueNodeIndex := i; fPresentQueueNodeIndex := i; break; end; end; if (fPresentQueueNodeIndex = high(fPresentQueueNodeIndex)) then begin for i := low(QueueFamProps) to high(QueueFamProps) do begin if fPhyDevice.GetSurfaceSupport(i, fSurface.Handle) then begin fPresentQueueNodeIndex := i; break; end; end; end; WriteLn(' graphics queue node index: ', fGraphicsQueueNodeIndex); WriteLn(' present queue node index: ', fPresentQueueNodeIndex); if (fGraphicsQueueNodeIndex = high(fGraphicsQueueNodeIndex)) or (fPresentQueueNodeIndex = high(fPresentQueueNodeIndex)) or (fPresentQueueNodeIndex <> fGraphicsQueueNodeIndex) then raise TvkuException.Create('different graphic and present queue node index is not supported yet'); WriteLn(' find suitable image format'); SrfFormats := fPhyDevice.GetSurfaceFormats(fSurface.Handle); if (Length(SrfFormats) = 0) then raise TvkuException.Create('no suitable formats found'); if (Length(SrfFormats) = 1) and (SrfFormats[0].format = VK_FORMAT_UNDEFINED) then begin fSurfaceFormat := VK_FORMAT_R8G8B8A8_UNORM; fSurfaceColorSpace := VK_COLORSPACE_SRGB_NONLINEAR_KHR; end else begin fSurfaceFormat := SrfFormats[0].format; fSurfaceColorSpace := SrfFormats[0].colorSpace; end; WriteLn(' format: ', fSurfaceFormat); WriteLn(' color space: ', fSurfaceColorSpace); WriteLn(' done'); finally FreeAndNil(SurfaceFactory); end; ////////////////////////////////////////////////////////////////////////////// WriteLn('create command pool'); CommandPoolFactory := TvkuCommandPoolFactory.Create(fDevice); try CommandPoolFactory.Flags := [ VK_COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT ]; CommandPoolFactory.QueueFamilyIndex := fGraphicsQueueNodeIndex; fCommandPool := CommandPoolFactory.CreateCommandPool; WriteLn(' handle: ', PtrUInt(fCommandPool.Handle)); WriteLn(' alloc command buffer'); fCommandBuffer := TvkuCommandBuffer.Create( fCommandPool.CreateCommandBuffer(VK_COMMAND_BUFFER_LEVEL_PRIMARY), true, fCommandPool.Handle, fDevice.DeviceCommands); WriteLn(' handle: ', PtrUInt(fCommandBuffer.Handle)); WriteLn(' done'); finally FreeAndNil(CommandPoolFactory); end; ////////////////////////////////////////////////////////////////////////////// WriteLn('create swap chain'); SwapChainFactory := TvkuSwapChainFactory.Create(fDevice); try SwapChainFactory.AllocHandler := fAllocHandler; SwapChainFactory.Surface := fSurface.Handle; SwapChainFactory.ImageUsage := [ VK_IMAGE_USAGE_COLOR_ATTACHMENT_BIT ]; SwapChainFactory.ImageArrayLayers := 1; SwapChainFactory.ImageSharingMode := VK_SHARING_MODE_EXCLUSIVE; SwapChainFactory.Clipped := true; SwapChainFactory.ComposideAlpha := [ VK_COMPOSITE_ALPHA_OPAQUE_BIT_KHR ]; SwapChainFactory.ImageFormat := fSurfaceFormat; SwapChainFactory.ImageColorSpace := fSurfaceColorSpace; WriteLn(' get surface capabilities'); SurfaceCapabilities := fPhyDevice.GetSurfaceCapabilities(fSurface.Handle); if (SurfaceCapabilities.currentExtent.width = High(VkUint32)) then begin SurfaceCapabilities.currentExtent.width := ClientWidth; SurfaceCapabilities.currentExtent.height := ClientHeight; end else begin ClientWidth := SurfaceCapabilities.currentExtent.width; ClientHeight := SurfaceCapabilities.currentExtent.height; end; WriteLn(' width: ', SurfaceCapabilities.currentExtent.width); WriteLn(' height: ', SurfaceCapabilities.currentExtent.height); SwapChainFactory.ImageExtent := SurfaceCapabilities.currentExtent; Write(' set min image count... '); SwapChainFactory.MinImageCount := SurfaceCapabilities.minImageCount + 1; if (SurfaceCapabilities.maxImageCount > 0) and (SwapChainFactory.MinImageCount > SurfaceCapabilities.maxImageCount) then SwapChainFactory.MinImageCount := SurfaceCapabilities.maxImageCount; WriteLn(SwapChainFactory.MinImageCount); WriteLn(' set pre transform...'); SwapChainFactory.PreTransform := SurfaceCapabilities.currentTransform; if (VK_SURFACE_TRANSFORM_IDENTITY_BIT_KHR in SurfaceCapabilities.supportedTransforms) then SwapChainFactory.PreTransform := [ VK_SURFACE_TRANSFORM_IDENTITY_BIT_KHR ]; Write(' find suitable present mode... '); PresentModes := fPhyDevice.GetSurfacePresentModes(fSurface.Handle); if (Length(PresentModes) = 0) then raise TvkuException.Create('unable to get present modes'); for pm in PresentModes do begin if (pm = VK_PRESENT_MODE_MAILBOX_KHR) then begin SwapChainFactory.PresentMode := pm; break; end; end; WriteLn(SwapChainFactory.PresentMode); fSwapChain := SwapChainFactory.CreateSwapchain; WriteLn(' handle: ', PtrUInt(fSwapChain.Handle)); WriteLn(' done'); finally FreeAndNil(SwapChainFactory); end; ////////////////////////////////////////////////////////////////////////////// WriteLn('create image views'); Images := fSwapChain.GetImages; SetLength(fImageViews, Length(Images)); ImageViewFactory := TvkuImageViewFactory.Create(fDevice); try ImageViewFactory.AllocHandler := fAllocHandler; ImageViewFactory.Format := fSurfaceFormat; ImageViewFactory.ViewType := VK_IMAGE_VIEW_TYPE_2D; with ImageViewFactory.SubresourceRange do begin AspectMask := [ VK_IMAGE_ASPECT_COLOR_BIT ]; BaseMipLevel := 0; LevelCount := 1; BaseArrayLayer := 0; LayerCount := 1; end; with ImageViewFactory.Components do begin r := VK_COMPONENT_SWIZZLE_R; g := VK_COMPONENT_SWIZZLE_G; b := VK_COMPONENT_SWIZZLE_B; a := VK_COMPONENT_SWIZZLE_A; end; for i := Low(fImageViews) to High(fImageViews) do begin // TODO create image barrier ImageViewFactory.Image := Images[i]; fImageViews[i] := ImageViewFactory.CreateImageView; WriteLn(' handle: ', PtrUInt(fImageViews[i].Handle)); end; WriteLn(' done'); finally FreeAndNil(ImageViewFactory); end; ////////////////////////////////////////////////////////////////////////////// WriteLn('create render pass'); RenderPassFactory := TvkuRenderPassFactory.Create(fDevice); try RenderPassFactory.Attachments.Length := 2; with RenderPassFactory.Attachments[0] do begin Format := fSurfaceFormat; Samples := [ VK_SAMPLE_COUNT_1_BIT ]; LoadOp := VK_ATTACHMENT_LOAD_OP_CLEAR; StoreOp := VK_ATTACHMENT_STORE_OP_STORE; StencilLoadOp := VK_ATTACHMENT_LOAD_OP_DONT_CARE; StencilStoreOp := VK_ATTACHMENT_STORE_OP_DONT_CARE; InitialLayout := VK_IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL; FinalLayout := VK_IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL; end; with RenderPassFactory.Attachments[1] do begin Format := DepthFormat; Samples := [ VK_SAMPLE_COUNT_1_BIT ]; LoadOp := VK_ATTACHMENT_LOAD_OP_CLEAR; StoreOp := VK_ATTACHMENT_STORE_OP_STORE; StencilLoadOp := VK_ATTACHMENT_LOAD_OP_DONT_CARE; StencilStoreOp := VK_ATTACHMENT_STORE_OP_DONT_CARE; InitialLayout := VK_IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL; FinalLayout := VK_IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL; end; RenderPassFactory.Subpasses.Length := 1; with RenderPassFactory.Subpasses[0] do begin PipelineBindPoint := VK_PIPELINE_BIND_POINT_GRAPHICS; ColorAttachments.Length := 1; ColorAttachments[0].Attachment := 0; ColorAttachments[0].Layout := VK_IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL; DepthStencilAttachments.Length := 1; DepthStencilAttachments[0].Attachment := 1; DepthStencilAttachments[0].Layout := VK_IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL; end; RenderPassFactory.AllocHandler := fAllocHandler; fRenderPass := RenderPassFactory.CreateRenderPass; WriteLn(' handle: ', PtrUInt(fRenderPass.Handle)); WriteLn(' done'); finally FreeAndNil(RenderPassFactory); end; ////////////////////////////////////////////////////////////////////////////// WriteLn('create frame buffers'); FrameBufferFactory := TvkuFrameBufferFactory.Create(fDevice); try SetLength(fFrameBuffers, Length(fImageViews)); FrameBufferFactory.AllocHandler := fAllocHandler; FrameBufferFactory.RenderPass := fRenderPass.Handle; FrameBufferFactory.Width := SurfaceCapabilities.currentExtent.width; FrameBufferFactory.Height := SurfaceCapabilities.currentExtent.height; FrameBufferFactory.Layers := 1; FrameBufferFactory.Attachments.Length := 1; for i := low(fFrameBuffers) to high(fFrameBuffers) do begin FrameBufferFactory.Attachments[0] := fImageViews[i].Handle; fFrameBuffers[i] := FrameBufferFactory.CreateFrameBuffer; WriteLn(' handle: ', PtrUInt(fFrameBuffers[i].Handle)); end; WriteLn(' done'); finally FreeAndNil(FrameBufferFactory); end; ////////////////////////////////////////////////////////////////////////////// WriteLn('create descriptor set layout'); DescSetLayoutFactory := TvkuDescriptorSetLayoutFactory.Create(fDevice); try DescSetLayoutFactory.Bindings.Length := 1; with DescSetLayoutFactory.Bindings[0] do begin Binding := 0; // binding 0 (Uniform Buffer/Vertex Shader) DescriptorType := VK_DESCRIPTOR_TYPE_UNIFORM_BUFFER; DescriptorCount := 1; StageFlags := [ VK_SHADER_STAGE_VERTEX_BIT ]; end; DescSetLayoutFactory.AllocHandler := fAllocHandler; fDescSetLayout := DescSetLayoutFactory.CreateDescriptorSetLayout; WriteLn(' handle: ', PtrUInt(fDescSetLayout.Handle)); WriteLn(' done'); finally FreeAndNil(DescSetLayoutFactory); end; ////////////////////////////////////////////////////////////////////////////// WriteLn('create pipeline layout'); PipelineLayoutFactory := TvkuPipelineLayoutFactory.Create(fDevice); try PipelineLayoutFactory.AllocHandler := fAllocHandler; PipelineLayoutFactory.SetLayouts.Length := 1; PipelineLayoutFactory.SetLayouts[0] := fDescSetLayout.Handle; fPipelineLayout := PipelineLayoutFactory.CreatePipelineLayout; WriteLn(' handle: ', PtrUInt(fPipelineLayout.Handle)); WriteLn(' done'); finally FreeAndNil(PipelineLayoutFactory); end; ////////////////////////////////////////////////////////////////////////////// WriteLn('create shader modules'); ShaderModuleFactory := TvkuShaderModuleFactory.Create(fDevice); try ShaderModuleFactory.AllocHandler := fAllocHandler; ShaderModuleFactory.LoadGlslCode(ExtractFilePath(Application.ExeName) + '../../data/shaders/triangle.vert', [ VK_SHADER_STAGE_VERTEX_BIT ]); fVertexShader := ShaderModuleFactory.CreateShaderModule; WriteLn(' vertex handle: ', PtrUInt(fVertexShader.Handle)); ShaderModuleFactory.LoadGlslCode(ExtractFilePath(Application.ExeName) + '../../data/shaders/triangle.frag', [ VK_SHADER_STAGE_FRAGMENT_BIT ]); fFragmentShader := ShaderModuleFactory.CreateShaderModule; WriteLn(' fragment handle: ', PtrUInt(fFragmentShader.Handle)); WriteLn(' done'); finally FreeAndNil(ShaderModuleFactory); end; ////////////////////////////////////////////////////////////////////////////// WriteLn('create graphics pipeline'); PipelineFactory := TvkuGraphicsPipelineFactory.Create(fDevice); try PipelineFactory.AllocHandler := fAllocHandler; // TODO fPipeline := PipelineFactory.CreateGraphicsPipeline(VK_INVALID_NDP_HANDLE); finally FreeAndNil(PipelineFactory); end; end; ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// procedure TMainForm.FormDestroy(Sender: TObject); procedure FreeAndNilFrameBuffers; var i: Integer; begin for i := Low(fFrameBuffers) to High(fFrameBuffers) do FreeAndNil(fFrameBuffers[i]); SetLength(fFrameBuffers, 0); end; procedure FreeAndNilImageViews; var i: Integer; begin for i := Low(fImageViews) to High(fImageViews) do FreeAndNil(fImageViews[i]); SetLength(fImageViews, 0); end; begin FreeAndNil(fPipeline); FreeAndNil(fFragmentShader); FreeAndNil(fVertexShader); FreeAndNil(fPipelineLayout); FreeAndNil(fDescSetLayout); FreeAndNilFrameBuffers; FreeAndNil(fRenderPass); FreeAndNilImageViews; FreeAndNil(fSwapChain); FreeAndNil(fSurface); FreeAndNil(fQueue); FreeAndNil(fDevice); FreeAndNil(fPhyDevice); FreeAndNil(fDebugReporter); FreeAndNil(fInstance); FreeAndNil(fAllocHandler); end; end.