giant step forward
This commit is contained in:
parent
3ca8e62367
commit
a95928ee9b
1 changed files with 132 additions and 150 deletions
280
src/Main.hs
280
src/Main.hs
|
@ -9,30 +9,25 @@ import Control.Monad
|
||||||
import Control.Monad.Loops
|
import Control.Monad.Loops
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Trans.Resource
|
import Control.Monad.Trans.Resource
|
||||||
import Control.Monad.Trans.Maybe
|
|
||||||
import Data.Bits
|
|
||||||
import qualified Data.ByteString as BS
|
import qualified Data.ByteString as BS
|
||||||
import Data.Maybe
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
import Data.Word
|
import Data.Word
|
||||||
import qualified SDL
|
import qualified SDL hiding (V2)
|
||||||
import qualified SDL.Video.Vulkan as SDL
|
import qualified SDL.Video.Vulkan as SDL
|
||||||
import qualified Control.Concurrent.STM as STM
|
import qualified Control.Concurrent.STM as STM
|
||||||
|
import Foreign.C.Types (CInt)
|
||||||
import Foreign.Ptr
|
import Foreign.Ptr
|
||||||
|
import Linear
|
||||||
import qualified Vulkan as Vk
|
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 Vulkan.Zero as Vk
|
||||||
import qualified VulkanMemoryAllocator as Vk
|
import qualified Vulkan.CStruct.Extends as Vk
|
||||||
|
|
||||||
myApiVersion :: Word32
|
myApiVersion :: Word32
|
||||||
myApiVersion = Vk.API_VERSION_1_2
|
myApiVersion = Vk.API_VERSION_1_3
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = runResourceT $ do
|
main = runResourceT $ do
|
||||||
(window, inst, surface) <- initEngine
|
(window, inst, surface, swapchain, images) <- initEngine
|
||||||
|
|
||||||
SDL.showWindow window
|
SDL.showWindow window
|
||||||
|
|
||||||
|
@ -56,12 +51,12 @@ main = runResourceT $ do
|
||||||
evs
|
evs
|
||||||
)
|
)
|
||||||
|
|
||||||
quitEngine window inst surface
|
initEngine
|
||||||
|
:: MonadResource m
|
||||||
initEngine :: MonadResource m => m (SDL.Window, Vk.Instance, Vk.SurfaceKHR)
|
=> m (SDL.Window, Vk.Instance, Vk.SurfaceKHR, Vk.SwapchainKHR, V.Vector Vk.Image)
|
||||||
initEngine = do
|
initEngine = do
|
||||||
-- initialize SDL2 with all subsystems
|
-- initialize SDL2 with all subsystems
|
||||||
SDL.initializeAll
|
void $ allocate_ SDL.initializeAll SDL.quit
|
||||||
|
|
||||||
-- create a window configuration
|
-- create a window configuration
|
||||||
let windowConfig = SDL.defaultWindow
|
let windowConfig = SDL.defaultWindow
|
||||||
|
@ -72,170 +67,157 @@ initEngine = do
|
||||||
SDL.vkLoadLibrary Nothing
|
SDL.vkLoadLibrary Nothing
|
||||||
|
|
||||||
-- create the window
|
-- 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
|
||||||
initVulkan :: MonadResource m => SDL.Window -> m (Vk.SurfaceKHR, Vk.Instance)
|
=> SDL.Window
|
||||||
|
-> m (Vk.SurfaceKHR, Vk.Instance, Vk.SwapchainKHR, V.Vector Vk.Image)
|
||||||
initVulkan window = do
|
initVulkan window = do
|
||||||
|
|
||||||
vulkanInstance <- createInstance window
|
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))
|
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
|
||||||
DeviceParams
|
)
|
||||||
devName
|
(\vulkanSurface -> do
|
||||||
physicalDevice
|
print ("destroying Surface" :: String)
|
||||||
logicalDevice
|
Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
|
||||||
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
|
dimensions <- liftIO $ SDL.windowInitialSize <$> SDL.getWindowConfig window
|
||||||
|
swapchain <- createSwapchain vulkanSurface dimensions vulkanLogicalDevice
|
||||||
|
images <- getImageHandles swapchain vulkanLogicalDevice
|
||||||
|
|
||||||
liftIO $ print ("Using device: " <> devName)
|
return (vulkanSurface, vulkanInstance, swapchain, images)
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
createInstance :: MonadResource m => SDL.Window -> m Vk.Instance
|
createInstance :: MonadResource m => SDL.Window -> m Vk.Instance
|
||||||
createInstance window = do
|
createInstance window = do
|
||||||
windowExtensions <- liftIO $
|
windowExtensions <- liftIO $ fmap (Vk.EXT_DEBUG_UTILS_EXTENSION_NAME :) $
|
||||||
traverse BS.packCString =<< SDL.vkGetInstanceExtensions window
|
traverse BS.packCString =<< SDL.vkGetInstanceExtensions window
|
||||||
|
liftIO $ do
|
||||||
|
print ("activating followinfg rxtensions:" :: String)
|
||||||
|
print windowExtensions
|
||||||
let createInfo = Vk.zero
|
let createInfo = Vk.zero
|
||||||
{ Vk.applicationInfo = Just Vk.zero
|
{ Vk.applicationInfo = Just Vk.zero
|
||||||
{ Vk.applicationName = Nothing
|
{ Vk.applicationName = Nothing
|
||||||
, Vk.apiVersion = myApiVersion
|
, 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 =
|
-- requirements =
|
||||||
[Vk.RequireInstanceExtension Nothing n minBound | n <- windowExtensions ]
|
-- [Vk.RequireInstanceExtension Nothing n minBound | n <- windowExtensions ]
|
||||||
Vk.createDebugInstanceFromRequirements requirements [] createInfo
|
|
||||||
|
|
||||||
data DeviceParams = DeviceParams
|
(_, inst) <- allocate
|
||||||
{ dpDevicename :: T.Text
|
(Vk.createInstance createInfo Nothing)
|
||||||
, dpPhysicalDevice :: Vk.PhysicalDevice
|
(`Vk.destroyInstance` Nothing)
|
||||||
, dpDevice :: Vk.Device
|
|
||||||
, dpGraphicsQueue :: Vk.Queue
|
|
||||||
, dpGraphicsQueueFamilyIndex :: Word32
|
|
||||||
}
|
|
||||||
|
|
||||||
createDevice
|
return inst
|
||||||
:: MonadResource m
|
|
||||||
|
pickPhysicalDevice
|
||||||
|
:: (MonadResource m)
|
||||||
=> Vk.Instance
|
=> Vk.Instance
|
||||||
-> Vk.SurfaceKHR
|
-> m Vk.PhysicalDevice
|
||||||
-> m DeviceParams
|
pickPhysicalDevice vkInstance = do
|
||||||
createDevice inst surface = do
|
physDevices <- snd <$> Vk.enumeratePhysicalDevices vkInstance
|
||||||
(pdi, physDevice) <-
|
|
||||||
fromMaybe (error "Unable to find suitable physival device!") <$>
|
|
||||||
Vk.pickPhysicalDevice inst (physicalDeviceInfo surface) id
|
|
||||||
|
|
||||||
devName <- Vk.physicalDeviceName physDevice
|
devicesWithProps <- V.mapM
|
||||||
|
(\device -> do
|
||||||
|
devProps <- Vk.getPhysicalDeviceProperties device
|
||||||
|
return (device, devProps)
|
||||||
|
)
|
||||||
|
physDevices
|
||||||
|
|
||||||
--
|
let discretePhysDevices = V.filter
|
||||||
-- get logical device
|
(\(_, 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
|
deviceCreateInfo = Vk.zero
|
||||||
{ Vk.queueCreateInfos =
|
{ Vk.queueCreateInfos = V.singleton (Vk.SomeStruct queueCreateInfo)
|
||||||
[ Vk.SomeStruct Vk.zero
|
, Vk.enabledExtensionNames = extensionNames
|
||||||
{ 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
|
(_, logDevice) <- allocate
|
||||||
devName
|
(Vk.createDevice physDevice deviceCreateInfo Nothing)
|
||||||
physDevice
|
(\logDevice -> do
|
||||||
device
|
print ("destroying logical device" :: String)
|
||||||
graphicsQueue
|
Vk.destroyDevice logDevice Nothing
|
||||||
graphicsQueueFamilyIndex
|
)
|
||||||
|
|
||||||
data PhysicalDeviceInfo = PhysicalDeviceInfo
|
return logDevice
|
||||||
{ pdiTotalMemory :: Word64
|
|
||||||
, pdiGraphicsQueueFamilyIndex :: Word32
|
|
||||||
}
|
|
||||||
deriving (Eq, Ord)
|
|
||||||
|
|
||||||
physicalDeviceInfo
|
createSwapchain
|
||||||
:: MonadIO m
|
:: (MonadResource m)
|
||||||
=> Vk.SurfaceKHR
|
=> Vk.SurfaceKHR
|
||||||
-> Vk.PhysicalDevice
|
-> V2 CInt
|
||||||
-> m (Maybe PhysicalDeviceInfo)
|
-> Vk.Device
|
||||||
physicalDeviceInfo surface phys = runMaybeT $ do
|
-> m Vk.SwapchainKHR
|
||||||
-- We need swapchains
|
createSwapchain surface windowDimension logicalDevice = do
|
||||||
guard =<< deviceHasSwapchains phys
|
let createInfo = Vk.zero
|
||||||
|
{ Vk.surface = surface
|
||||||
-- We also need graphics and present queues
|
, Vk.minImageCount = 4
|
||||||
pdiGraphicsQueueFamilyIndex <- do
|
, Vk.imageFormat = Vk.FORMAT_B8G8R8A8_SRGB
|
||||||
queueFamilyProperties <- Vk.getPhysicalDeviceQueueFamilyProperties phys
|
, Vk.imageColorSpace = Vk.COLOR_SPACE_SRGB_NONLINEAR_KHR
|
||||||
let isGraphicsQueue q =
|
, Vk.imageExtent =
|
||||||
((Vk.QUEUE_GRAPHICS_BIT .&. Vk.queueFlags q) > Vk.QueueFlagBits 0) &&
|
(\(V2 w h) -> Vk.Extent2D (fromIntegral w) (fromIntegral h)) windowDimension
|
||||||
(Vk.queueCount q > 0)
|
, Vk.imageArrayLayers = 1
|
||||||
graphicsQueueIndices = fromIntegral . fst <$> V.filter
|
, Vk.imageUsage = Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT
|
||||||
(isGraphicsQueue . snd)
|
, Vk.presentMode = Vk.PRESENT_MODE_MAILBOX_KHR
|
||||||
(V.indexed queueFamilyProperties)
|
, Vk.preTransform = Vk.SURFACE_TRANSFORM_IDENTITY_BIT_KHR
|
||||||
isPresentQueue i = Vk.getPhysicalDeviceSurfaceSupportKHR phys i surface
|
, Vk.compositeAlpha = Vk.COMPOSITE_ALPHA_INHERIT_BIT_KHR
|
||||||
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
|
|
||||||
|
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
|
||||||
|
|
Loading…
Reference in a new issue