giant step forward
This commit is contained in:
parent
3ca8e62367
commit
a95928ee9b
1 changed files with 132 additions and 150 deletions
282
src/Main.hs
282
src/Main.hs
|
|
@ -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 <$>
|
||||
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
|
||||
DeviceParams
|
||||
devName
|
||||
physicalDevice
|
||||
logicalDevice
|
||||
graphicsQueue
|
||||
graphicsQueueFamilyIndex <- createDevice vulkanInstance vulkanSurface
|
||||
vulkanPhysicalDevice <- pickPhysicalDevice vulkanInstance
|
||||
vulkanLogicalDevice <- createLogicalDevice vulkanPhysicalDevice
|
||||
|
||||
let commandPoolCreateInfo = Vk.zero
|
||||
{ Vk.queueFamilyIndex = graphicsQueueFamilyIndex
|
||||
} :: Vk.CommandPoolCreateInfo
|
||||
commandPools <-
|
||||
V.replicateM
|
||||
3
|
||||
(snd <$>
|
||||
Vk.withCommandPool logicalDevice commandPoolCreateInfo Nothing allocate
|
||||
)
|
||||
(_, vulkanSurface) <- allocate
|
||||
(Vk.SurfaceKHR <$>
|
||||
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
|
||||
)
|
||||
(\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
|
||||
deviceCreateInfo = Vk.zero
|
||||
{ Vk.queueCreateInfos =
|
||||
[ Vk.SomeStruct Vk.zero
|
||||
{ Vk.queueFamilyIndex = graphicsQueueFamilyIndex
|
||||
, Vk.queuePriorities = [ 1 ]
|
||||
}
|
||||
]
|
||||
, Vk.enabledExtensionNames = [ Vk.KHR_SWAPCHAIN_EXTENSION_NAME ]
|
||||
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 = V.singleton (Vk.SomeStruct queueCreateInfo)
|
||||
, Vk.enabledExtensionNames = extensionNames
|
||||
}
|
||||
(_, 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
|
||||
-> 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
|
||||
}
|
||||
|
||||
-- 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)
|
||||
snd <$> allocate
|
||||
(Vk.createSwapchainKHR logicalDevice createInfo Nothing)
|
||||
(\swapchain -> Vk.destroySwapchainKHR logicalDevice swapchain Nothing)
|
||||
|
||||
-- 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
|
||||
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