diff --git a/src/Main.hs b/src/Main.hs index 89a24f3..ceea71a 100644 --- a/src/Main.hs +++ b/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