giant step forward

This commit is contained in:
nek0 2022-07-10 19:31:44 +02:00
parent 3ca8e62367
commit a95928ee9b

View file

@ -9,30 +9,25 @@ import Control.Monad
import Control.Monad.Loops
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Control.Monad.Trans.Maybe
import Data.Bits
import qualified Data.ByteString as BS
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Word
import qualified SDL
import qualified SDL hiding (V2)
import qualified SDL.Video.Vulkan as SDL
import qualified Control.Concurrent.STM as STM
import Foreign.C.Types (CInt)
import Foreign.Ptr
import Linear
import qualified Vulkan as Vk
import qualified Vulkan.CStruct.Extends as Vk
import qualified Vulkan.Requirement as Vk
import qualified Vulkan.Utils.Initialization as Vk
import qualified Vulkan.Zero as Vk
import qualified VulkanMemoryAllocator as Vk
import qualified Vulkan.CStruct.Extends as Vk
myApiVersion :: Word32
myApiVersion = Vk.API_VERSION_1_2
myApiVersion = Vk.API_VERSION_1_3
main :: IO ()
main = runResourceT $ do
(window, inst, surface) <- initEngine
(window, inst, surface, swapchain, images) <- initEngine
SDL.showWindow window
@ -56,12 +51,12 @@ main = runResourceT $ do
evs
)
quitEngine window inst surface
initEngine :: MonadResource m => m (SDL.Window, Vk.Instance, Vk.SurfaceKHR)
initEngine
:: MonadResource m
=> m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.Image)
initEngine = do
-- initialize SDL2 with all subsystems
SDL.initializeAll
void $ allocate_ SDL.initializeAll SDL.quit
-- create a window configuration
let windowConfig = SDL.defaultWindow
@ -72,170 +67,157 @@ initEngine = do
SDL.vkLoadLibrary Nothing
-- create the window
window <- SDL.createWindow "Haskell ❤️ Vulkan" windowConfig
(_, window) <-
allocate
(SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
(\window -> do
liftIO $ print ("destroying window" :: String)
SDL.destroyWindow window
)
(surface, inst) <- initVulkan window
-- create vulkan surface and vulkan instance from window
(surface, inst, swapchain, images) <- initVulkan window
return (window, inst, surface, swapchain, images)
return (window, inst, surface)
initVulkan :: MonadResource m => SDL.Window -> m (Vk.SurfaceKHR, Vk.Instance)
initVulkan
:: MonadResource m
=> SDL.Window
-> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.Image)
initVulkan window = do
vulkanInstance <- createInstance window
-- vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
-- vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
vulkanSurface <- Vk.SurfaceKHR <$>
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
(_, vulkanSurface) <- allocate
(Vk.SurfaceKHR <$>
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
DeviceParams
devName
physicalDevice
logicalDevice
graphicsQueue
graphicsQueueFamilyIndex <- createDevice vulkanInstance vulkanSurface
let commandPoolCreateInfo = Vk.zero
{ Vk.queueFamilyIndex = graphicsQueueFamilyIndex
} :: Vk.CommandPoolCreateInfo
commandPools <-
V.replicateM
3
(snd <$>
Vk.withCommandPool logicalDevice commandPoolCreateInfo Nothing allocate
)
(\vulkanSurface -> do
print ("destroying Surface" :: String)
Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
)
allocator <- createVMA vulkanInstance physicalDevice logicalDevice
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
swapchain <- createSwapchain vulkanSurface dimensions vulkanLogicalDevice
images <- getImageHandles swapchain vulkanLogicalDevice
liftIO $ print ("Using device: " <> devName)
return (vulkanSurface, vulkanInstance)
quitEngine
:: MonadResource m
=> SDL.Window
-> Vk.Instance
-> Vk.SurfaceKHR
-> m ()
quitEngine window inst surface = liftIO $ do
Vk.destroySurfaceKHR inst surface Nothing
Vk.destroyInstance inst Nothing
-- destroy window
SDL.destroyWindow window
-- quit SDL
SDL.quit
return (vulkanSurface, vulkanInstance, swapchain, images)
createInstance :: MonadResource m => SDL.Window -> m Vk.Instance
createInstance window = do
windowExtensions <- liftIO $
windowExtensions <- liftIO $ fmap (Vk.EXT_DEBUG_UTILS_EXTENSION_NAME :) $
traverse BS.packCString =<< SDL.vkGetInstanceExtensions window
liftIO $ do
print ("activating followinfg rxtensions:" :: String)
print windowExtensions
let createInfo = Vk.zero
{ Vk.applicationInfo = Just Vk.zero
{ Vk.applicationName = Nothing
, Vk.apiVersion = myApiVersion
}
-- enable debug util extension for debugging purposes
, Vk.enabledExtensionNames = V.fromList windowExtensions
-- enable validation layer for debugging purposes
, Vk.enabledLayerNames = V.singleton "VK_LAYER_KHRONOS_validation"
}
requirements =
[Vk.RequireInstanceExtension Nothing n minBound | n <- windowExtensions ]
Vk.createDebugInstanceFromRequirements requirements [] createInfo
-- requirements =
-- [Vk.RequireInstanceExtension Nothing n minBound | n <- windowExtensions ]
data DeviceParams = DeviceParams
{ dpDevicename :: T.Text
, dpPhysicalDevice :: Vk.PhysicalDevice
, dpDevice :: Vk.Device
, dpGraphicsQueue :: Vk.Queue
, dpGraphicsQueueFamilyIndex :: Word32
}
(_, inst) <- allocate
(Vk.createInstance createInfo Nothing)
(`Vk.destroyInstance` Nothing)
createDevice
:: MonadResource m
return inst
pickPhysicalDevice
:: (MonadResource m)
=> Vk.Instance
-> Vk.SurfaceKHR
-> m DeviceParams
createDevice inst surface = do
(pdi, physDevice) <-
fromMaybe (error "Unable to find suitable physival device!") <$>
Vk.pickPhysicalDevice inst (physicalDeviceInfo surface) id
-> m Vk.PhysicalDevice
pickPhysicalDevice vkInstance = do
physDevices <- snd <$> Vk.enumeratePhysicalDevices vkInstance
devName <- Vk.physicalDeviceName physDevice
devicesWithProps <- V.mapM
(\device -> do
devProps <- Vk.getPhysicalDeviceProperties device
return (device, devProps)
)
physDevices
--
-- get logical device
--
let discretePhysDevices = V.filter
(\(_, devProp) -> Vk.deviceType devProp == Vk.PHYSICAL_DEVICE_TYPE_DISCRETE_GPU)
devicesWithProps
maxMemdiscretePhysDevice = fst $ V.foldl
(\acc@(_, devProp1) ndev@(_, devProp2) ->
let dimension = Vk.maxImageDimension2D . Vk.limits
in
if dimension devProp1 < dimension devProp2
then ndev
else acc
)
(V.head discretePhysDevices)
discretePhysDevices
let graphicsQueueFamilyIndex = pdiGraphicsQueueFamilyIndex pdi
return maxMemdiscretePhysDevice
createLogicalDevice
:: (MonadResource m)
=> Vk.PhysicalDevice
-> m Vk.Device
createLogicalDevice physDevice = do
let priorities = V.singleton 1
extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME
queueCreateInfo = Vk.zero
{ Vk.queueFamilyIndex = 0
, Vk.queuePriorities = priorities
}
deviceCreateInfo = Vk.zero
{ Vk.queueCreateInfos =
[ Vk.SomeStruct Vk.zero
{ Vk.queueFamilyIndex = graphicsQueueFamilyIndex
, Vk.queuePriorities = [ 1 ]
{ Vk.queueCreateInfos = V.singleton (Vk.SomeStruct queueCreateInfo)
, Vk.enabledExtensionNames = extensionNames
}
]
, Vk.enabledExtensionNames = [ Vk.KHR_SWAPCHAIN_EXTENSION_NAME ]
}
(_, device) <- Vk.withDevice physDevice deviceCreateInfo Nothing allocate
graphicsQueue <-
Vk.getDeviceQueue device graphicsQueueFamilyIndex 0
return $ DeviceParams
devName
physDevice
device
graphicsQueue
graphicsQueueFamilyIndex
(_, logDevice) <- allocate
(Vk.createDevice physDevice deviceCreateInfo Nothing)
(\logDevice -> do
print ("destroying logical device" :: String)
Vk.destroyDevice logDevice Nothing
)
data PhysicalDeviceInfo = PhysicalDeviceInfo
{ pdiTotalMemory :: Word64
, pdiGraphicsQueueFamilyIndex :: Word32
}
deriving (Eq, Ord)
return logDevice
physicalDeviceInfo
:: MonadIO m
createSwapchain
:: (MonadResource m)
=> Vk.SurfaceKHR
-> Vk.PhysicalDevice
-> m (Maybe PhysicalDeviceInfo)
physicalDeviceInfo surface phys = runMaybeT $ do
-- We need swapchains
guard =<< deviceHasSwapchains phys
-- We also need graphics and present queues
pdiGraphicsQueueFamilyIndex <- do
queueFamilyProperties <- Vk.getPhysicalDeviceQueueFamilyProperties phys
let isGraphicsQueue q =
((Vk.QUEUE_GRAPHICS_BIT .&. Vk.queueFlags q) > Vk.QueueFlagBits 0) &&
(Vk.queueCount q > 0)
graphicsQueueIndices = fromIntegral . fst <$> V.filter
(isGraphicsQueue . snd)
(V.indexed queueFamilyProperties)
isPresentQueue i = Vk.getPhysicalDeviceSurfaceSupportKHR phys i surface
presentQueueIndices <- V.filterM isPresentQueue graphicsQueueIndices
MaybeT (return $ presentQueueIndices V.!? 0)
-- Score based on total memory
pdiTotalMemory <- do
heaps <- Vk.memoryHeaps <$> Vk.getPhysicalDeviceMemoryProperties phys
return $ sum (( Vk.size :: Vk.MemoryHeap -> Vk.DeviceSize) <$> heaps)
return $ PhysicalDeviceInfo {..}
deviceHasSwapchains :: MonadIO m => Vk.PhysicalDevice -> m Bool
deviceHasSwapchains phys = do
(_, extensions) <- Vk.enumerateDeviceExtensionProperties phys Nothing
return $
V.any ((Vk.KHR_SWAPCHAIN_EXTENSION_NAME ==) . Vk.extensionName) extensions
createVMA :: MonadResource m => Vk.Instance -> Vk.PhysicalDevice -> Vk.Device -> m Vk.Allocator
createVMA inst physicalDevice logicalDevice = snd <$>
Vk.withAllocator
Vk.zero
{ Vk.flags = Vk.zero
, Vk.physicalDevice = Vk.physicalDeviceHandle physicalDevice
, Vk.device = Vk.deviceHandle logicalDevice
, Vk.instance' = Vk.instanceHandle inst
, Vk.vulkanApiVersion = myApiVersion
-> V2 CInt
-> Vk.Device
-> m Vk.SwapchainKHR
createSwapchain surface windowDimension logicalDevice = do
let createInfo = Vk.zero
{ Vk.surface = surface
, Vk.minImageCount = 4
, Vk.imageFormat = Vk.FORMAT_B8G8R8A8_SRGB
, Vk.imageColorSpace = Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR
, Vk.imageExtent =
(\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension
, Vk.imageArrayLayers = 1
, Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
, Vk.presentMode = Vk.PRESENT_MODE_MAILBOX_KHR
, Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR
, Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_INHERIT_BIT_KHR
}
allocate
snd <$> allocate
(Vk.createSwapchainKHR logicalDevice createInfo Nothing)
(\swapchain -> Vk.destroySwapchainKHR logicalDevice swapchain Nothing)
getImageHandles
:: (MonadResource m)
=> Vk.SwapchainKHR
-> Vk.Device
-> m (V.Vector Vk.Image)
getImageHandles swapchain logicalDevice = do
(result, handles) <- Vk.getSwapchainImagesKHR logicalDevice swapchain
when (result /= Vk.SUCCESS) $
error "getImageHandles: Failed acquiring images from swapchain"
return handles