vulkan-tutorial/src/Main.hs

242 lines
7 KiB
Haskell
Raw Normal View History

2022-01-14 07:59:38 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
2022-01-18 05:25:58 +00:00
{-# LANGUAGE RecordWildCards #-}
2022-01-14 07:59:38 +00:00
module Main where
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
2022-01-17 20:52:39 +00:00
import Data.Maybe
2022-01-14 07:59:38 +00:00
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Word
import qualified SDL
import qualified SDL.Video.Vulkan as SDL
import qualified Control.Concurrent.STM as STM
import Foreign.Ptr
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
2022-01-18 05:25:58 +00:00
import qualified VulkanMemoryAllocator as Vk
2022-01-14 07:59:38 +00:00
myApiVersion :: Word32
myApiVersion = Vk.API_VERSION_1_2
main :: IO ()
main = runResourceT $ do
2022-01-18 05:25:58 +00:00
(window, inst, surface) <- initEngine
2022-01-14 07:59:38 +00:00
SDL.showWindow window
-- create abort condition for upcoming lop
quit <- liftIO $ STM.newTMVarIO True
-- main loop
liftIO $ whileM_
(STM.atomically $ STM.readTMVar quit
)
( do
-- poll events
evs <- SDL.pollEvents
-- flip abort condition on window close
mapM_
(\e -> case SDL.eventPayload e of
SDL.WindowClosedEvent _ ->
void $ STM.atomically $ STM.swapTMVar quit False
_ -> return ()
)
evs
)
2022-01-18 05:25:58 +00:00
quitEngine window inst surface
2022-01-14 07:59:38 +00:00
2022-01-18 05:25:58 +00:00
initEngine :: MonadResource m => m (SDL.Window, Vk.Instance, Vk.SurfaceKHR)
2022-01-14 07:59:38 +00:00
initEngine = do
-- initialize SDL2 with all subsystems
SDL.initializeAll
-- create a window configuration
let windowConfig = SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.VulkanContext -- enable Vulkan support
}
-- load vulkan library
SDL.vkLoadLibrary Nothing
-- create the window
2022-01-18 05:25:58 +00:00
window <- SDL.createWindow "Haskell ❤️ Vulkan" windowConfig
2022-01-14 07:59:38 +00:00
2022-01-18 05:25:58 +00:00
(surface, inst) <- initVulkan window
2022-01-14 07:59:38 +00:00
2022-01-18 05:25:58 +00:00
return (window, inst, surface)
2022-01-14 07:59:38 +00:00
2022-01-18 05:25:58 +00:00
initVulkan :: MonadResource m => SDL.Window -> m (Vk.SurfaceKHR, Vk.Instance)
2022-01-14 07:59:38 +00:00
initVulkan window = do
vulkanInstance <- createInstance window
2022-01-17 20:52:39 +00:00
-- vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
-- vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
2022-01-14 07:59:38 +00:00
2022-01-18 05:25:58 +00:00
vulkanSurface <- 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
)
allocator <- createVMA vulkanInstance physicalDevice logicalDevice
liftIO $ print ("Using device: " <> devName)
return (vulkanSurface, vulkanInstance)
2022-01-14 07:59:38 +00:00
2022-01-18 05:25:58 +00:00
quitEngine
:: MonadResource m
=> SDL.Window
-> Vk.Instance
-> Vk.SurfaceKHR
-> m ()
quitEngine window inst surface = liftIO $ do
2022-01-17 20:52:39 +00:00
Vk.destroySurfaceKHR inst surface Nothing
2022-01-18 05:25:58 +00:00
Vk.destroyInstance inst Nothing
2022-01-14 07:59:38 +00:00
-- destroy window
SDL.destroyWindow window
-- quit SDL
SDL.quit
createInstance :: MonadResource m => SDL.Window -> m Vk.Instance
createInstance window = do
windowExtensions <- liftIO $
traverse BS.packCString =<< SDL.vkGetInstanceExtensions window
let createInfo = Vk.zero
{ Vk.applicationInfo = Just Vk.zero
{ Vk.applicationName = Nothing
, Vk.apiVersion = myApiVersion
}
}
requirements =
2022-01-18 05:25:58 +00:00
[Vk.RequireInstanceExtension Nothing n minBound | n <- windowExtensions ]
Vk.createDebugInstanceFromRequirements requirements [] createInfo
data DeviceParams = DeviceParams
{ dpDevicename :: T.Text
, dpPhysicalDevice :: Vk.PhysicalDevice
, dpDevice :: Vk.Device
, dpGraphicsQueue :: Vk.Queue
, dpGraphicsQueueFamilyIndex :: Word32
}
createDevice
:: 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
devName <- Vk.physicalDeviceName physDevice
--
-- get logical device
--
let graphicsQueueFamilyIndex = pdiGraphicsQueueFamilyIndex pdi
deviceCreateInfo = Vk.zero
{ Vk.queueCreateInfos =
[ Vk.SomeStruct Vk.zero
{ Vk.queueFamilyIndex = graphicsQueueFamilyIndex
, Vk.queuePriorities = [ 1 ]
}
]
, 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
data PhysicalDeviceInfo = PhysicalDeviceInfo
{ pdiTotalMemory :: Word64
, pdiGraphicsQueueFamilyIndex :: Word32
}
deriving (Eq, Ord)
physicalDeviceInfo
:: MonadIO 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
}
allocate