diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,14 @@ ## WIP +## [0.3] - 2020-11-24 + +- Change type of pickPhysicalDevice to return Nothing instead of throwing +- Add `checkCommandsExp` function to generate an expression checking specified + commands for non-nullness +- Expose Queue family index for queues assigned with `assignQueues` +- Add `Vulkan.Utils.ShaderQQ.Shaderc` to compile HLSL shaders + ## [0.2] - 2020-11-15 - Add `Vulkan.Utils.Misc` for handy functions used in Vulkan programs, but not diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: vulkan-utils -version: "0.2" +version: "0.3" synopsis: Utils for the vulkan package category: Graphics maintainer: Joe Hermaszewski @@ -27,7 +27,7 @@ - transformers - typed-process - vector - - vulkan >= 3.6.14 + - vulkan >= 3.6.14 && < 3.8 tests: doctests: diff --git a/src/Vulkan/Utils/CommandCheck.hs b/src/Vulkan/Utils/CommandCheck.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/CommandCheck.hs @@ -0,0 +1,164 @@ +{-# language TemplateHaskell #-} +{-# language NoMonadComprehensions #-} +{-# language MultiWayIf #-} +{-# language QuasiQuotes #-} + +module Vulkan.Utils.CommandCheck + ( checkCommandsExp + ) where + +import Control.Applicative ( (<|>) ) +import Control.Arrow ( (&&&) ) +import Data.Char +import Data.Functor ( (<&>) ) +import Data.List ( isPrefixOf + , isSuffixOf + , nub + ) +import Data.List.Extra ( dropEnd ) +import Data.Maybe ( catMaybes ) +import Foreign.Ptr +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Vulkan.Core10 (Instance(..), Device(..)) +import Vulkan.Dynamic + +-- | Create an expression which checks the function pointers for all the Vulkan +-- commands depended upon by the specified list of function names. +-- +-- It returns a list of function names corresponding to those functions with +-- null pointers. +-- +-- Your program can use this function to fail early if a command couldn't be +-- loaded for some reason (missing extension or layer for example). +-- +-- One can create a function called @checkCommands@ with the following: +-- @ +-- [d| checkCommands = $(checkCommandsExp ['withInstance, 'cmdDraw, ...]) |] +-- @ +-- +-- It has the type @IsString a => Instance -> Device -> [a]@ +-- +-- It looks basically like +-- +-- @ +-- \inst dev -> +-- [ name +-- | True <- [ nullFunPtr == pVkCreateDevice inst +-- , nullFunPtr == pVkCreateFence dev +-- .. +-- ] +-- | name <- [ "vkCreateDevice" +-- , "vkCreateFence" +-- .. +-- ] +-- ] +-- @ +checkCommandsExp + :: [Name] + -- ^ The names of functions from the @vulkan@ package. Unknown commands are + -- ignored + -> Q Exp +checkCommandsExp requestedCommands = do + instAccessors <- accessorNames ''InstanceCmds + deviceAccessors <- accessorNames ''DeviceCmds + let vkCommandNames = + nub . commandNames instAccessors deviceAccessors =<< requestedCommands + inst <- newName "inst" + device <- newName "device" + let isNull = \case + InstanceCmd i -> [|nullFunPtr == $(varE i) $(varE inst)|] + DeviceCmd i -> [|nullFunPtr == $(varE i) $(varE device)|] + [| \(Instance _ $(varP inst)) (Device _ $(varP device)) -> + [ name + | (True, name) <- zip + $(listE (isNull <$> vkCommandNames)) + $(lift (commandString <$> vkCommandNames)) + ] + |] + +-- | Given instance and device accessors and a function, find the function +-- pointer accessor names which it depends on +-- +-- >>> commandNames ['pVkCreateDevice, 'pVkDestroyDevice] ['pVkCreateFence] (mkName "withDevice") +-- [InstanceCmd Vulkan.Dynamic.pVkCreateDevice,InstanceCmd Vulkan.Dynamic.pVkDestroyDevice] +commandNames :: [Name] -> [Name] -> Name -> [DeviceOrInstanceCommand] +commandNames instAccessors deviceAccessors = + let instNames = (nameBase &&& id) <$> instAccessors + deviceNames = (nameBase &&& id) <$> deviceAccessors + findCommand :: String -> Maybe DeviceOrInstanceCommand + findCommand command = + (InstanceCmd <$> lookup command instNames) + <|> (DeviceCmd <$> lookup command deviceNames) + in \n -> + let candidates = commandCandidates (nameBase n) + in catMaybes $ findCommand <$> candidates + +data DeviceOrInstanceCommand + = DeviceCmd Name + | InstanceCmd Name + deriving (Eq, Show) + +-- | Get the C name of a function +-- +-- >>> commandString (DeviceCmd (mkName "pVkCreateInstance")) +-- "vkCreateInstance" +commandString :: DeviceOrInstanceCommand -> String +commandString = unPtrName . nameBase . \case + InstanceCmd n -> n + DeviceCmd n -> n + +-- | A list of potential sets of vulkan commands this name depends on, not all +-- of them will be valid names. +-- +-- >>> commandCandidates "withDevice" +-- ["pVkAllocateDevice","pVkFreeDevice","pVkCreateDevice","pVkDestroyDevice"] +-- +-- >>> commandCandidates "waitSemaphoresSafe" +-- ["pVkWaitSemaphores"] +-- +-- >>> commandCandidates "useCmdBuffer" +-- ["pVkBeginCmdBuffer","pVkEndCmdBuffer"] +-- +-- >>> commandCandidates "withSemaphore" +-- ["pVkAllocateSemaphore","pVkFreeSemaphore","pVkCreateSemaphore","pVkDestroySemaphore"] +commandCandidates :: String -> [String] +commandCandidates n = if + | "Safe" `isSuffixOf` n + -> commandCandidates (dropEnd 4 n) + | Just u <- stripPrefix "with" + -> (<> u) <$> ["pVkAllocate", "pVkFree", "pVkCreate", "pVkDestroy"] + | Just u <- stripPrefix "withMapped" + -> (<> u) <$> ["pVkMap", "pVkUnmap"] + | Just u <- stripPrefix "use" + -> (<> u) <$> ["pVkBegin", "pVkEnd"] + | Just u <- stripPrefix "cmdUse" + -> (<> u) <$> ["pVkCmdBegin", "pVkCmdEnd"] + | otherwise + -> ["pVk" <> upperCaseFirst n] + where + stripPrefix p = if p `isPrefixOf` n + then Just (upperCaseFirst (drop (length p) n)) + else Nothing + +-- | Get the record accessors of a type +-- +-- >>> $(lift . fmap show =<< accessorNames ''Device) +-- ["Vulkan.Core10.Handles.deviceHandle","Vulkan.Core10.Handles.deviceCmds"] +accessorNames :: Name -> Q [Name] +accessorNames record = reify record <&> \case + TyConI (DataD _ _ _ _ [con] _) + | RecC _ vars <- con -> firstOfThree <$> vars + | RecGadtC _ vars _ <- con -> firstOfThree <$> vars + _ -> fail "Name wasn't a TyConI" + where firstOfThree (a, _, _) = a + +unPtrName :: String -> String +unPtrName = \case + 'p' : 'V' : xs -> 'v' : xs + s -> s + +upperCaseFirst :: String -> String +upperCaseFirst = \case + x:xs -> toUpper x : xs + [] -> [] diff --git a/src/Vulkan/Utils/Initialization.hs b/src/Vulkan/Utils/Initialization.hs --- a/src/Vulkan/Utils/Initialization.hs +++ b/src/Vulkan/Utils/Initialization.hs @@ -8,7 +8,6 @@ , createDeviceWithExtensions ) where -import Control.Exception ( throwIO ) import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.Bits @@ -19,9 +18,6 @@ import Data.Text ( Text ) import Data.Text.Encoding ( decodeUtf8 ) import qualified Data.Vector as V -import GHC.IO.Exception ( IOErrorType(NoSuchThing) - , IOException(..) - ) import Vulkan.CStruct.Extends import Vulkan.Core10 import Vulkan.Extensions.VK_EXT_debug_utils @@ -148,30 +144,31 @@ -- | Get a single 'PhysicalDevice' deciding with a scoring function -- -- Pass a function which will extract any required values from a device in the --- spirit of parse-don't validate. Also provide a function to compare these --- results for sorting multiple devices. +-- spirit of parse-don't-validate. Also provide a function to compare these +-- results for sorting multiple suitable devices. -- --- For example the result function could return a tuple of device memory and --- the compute queue family index, and the scoring function could be 'fst' to --- select devices based on their memory capacity. +-- As an example, the suitability function could return a tuple of device +-- memory and the compute queue family index, and the scoring function could be +-- 'fst' to select devices based on their memory capacity. Consider using +-- 'Vulkan.Utils.QueueAssignment.assignQueues' to find your desired queues in +-- the suitability function. -- --- If no devices are deemed suitable then an 'IOError' is thrown. +-- If no devices are deemed suitable then a 'NoSuchThing' 'IOError' is thrown. pickPhysicalDevice :: (MonadIO m, Ord b) => Instance -> (PhysicalDevice -> m (Maybe a)) - -- ^ Some result for a PhysicalDevice, Nothing if it is not to be chosen. + -- ^ A suitability funcion for a 'PhysicalDevice', 'Nothing' if it is not to + -- be chosen. -> (a -> b) -- ^ Scoring function to rate this result - -> m (a, PhysicalDevice) + -> m (Maybe (a, PhysicalDevice)) -- ^ The score and the device pickPhysicalDevice inst devInfo score = do (_, devs) <- enumeratePhysicalDevices inst - infos <- catMaybes + infos <- catMaybes <$> sequence [ fmap (, d) <$> devInfo d | d <- toList devs ] - case maximumByMay (comparing (score.fst)) infos of - Nothing -> liftIO $ noSuchThing "Unable to find appropriate PhysicalDevice" - Just d -> pure d + pure $ maximumByMay (comparing (score . fst)) infos -- | Extract the name of a 'PhysicalDevice' with 'getPhysicalDeviceProperties' physicalDeviceName :: MonadIO m => PhysicalDevice -> m Text @@ -222,10 +219,6 @@ ---------------------------------------------------------------- -- Utils ---------------------------------------------------------------- - -noSuchThing :: String -> IO a -noSuchThing message = - throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing maximumByMay :: Foldable t => (a -> a -> Ordering) -> t a -> Maybe a maximumByMay f xs = if null xs then Nothing else Just (maximumBy f xs) diff --git a/src/Vulkan/Utils/QueueAssignment.hs b/src/Vulkan/Utils/QueueAssignment.hs --- a/src/Vulkan/Utils/QueueAssignment.hs +++ b/src/Vulkan/Utils/QueueAssignment.hs @@ -8,7 +8,7 @@ , isGraphicsQueueFamily , isTransferQueueFamily , isTransferOnlyQueueFamily - , isPresentQueue + , isPresentQueueFamily ) where import Control.Applicative @@ -78,10 +78,10 @@ -- your queues like: -- -- @ --- data MyQueues a = MyQueues --- { computeQueue :: a --- , graphicsAndPresentQueue :: a --- , transferQueue :: a +-- data MyQueues q = MyQueues +-- { computeQueue :: q +-- , graphicsAndPresentQueue :: q +-- , transferQueue :: q -- } -- -- myQueueSpecs :: MyQueues QueueSpec @@ -102,7 +102,9 @@ -- ^ A set of requirements for 'Queue's to be created -> m ( Maybe - (Vector (DeviceQueueCreateInfo '[]), Device -> n (f Queue)) + ( Vector (DeviceQueueCreateInfo '[]) + , Device -> n (f (QueueFamilyIndex, Queue)) + ) ) -- ^ -- - A set of 'DeviceQueueCreateInfo's to pass to 'createDevice' @@ -177,11 +179,11 @@ ] -- Get - extractQueues :: Device -> n (f Queue) + extractQueues :: Device -> n (f (QueueFamilyIndex, Queue)) extractQueues dev = for specsWithQueueIndex - $ \(_, QueueFamilyIndex familyIndex, QueueIndex index) -> - getDeviceQueue dev familyIndex index + $ \(_, i@(QueueFamilyIndex familyIndex), QueueIndex index) -> + (i, ) <$> getDeviceQueue dev familyIndex index pure (queueCreateInfos, extractQueues) @@ -208,9 +210,9 @@ == QUEUE_TRANSFER_BIT -- | Can this queue family present to this surface on this device -isPresentQueue +isPresentQueueFamily :: MonadIO m => PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool -isPresentQueue phys surf (QueueFamilyIndex i) = +isPresentQueueFamily phys surf (QueueFamilyIndex i) = getPhysicalDeviceSurfaceSupportKHR phys i surf ---------------------------------------------------------------- diff --git a/src/Vulkan/Utils/ShaderQQ.hs b/src/Vulkan/Utils/ShaderQQ.hs --- a/src/Vulkan/Utils/ShaderQQ.hs +++ b/src/Vulkan/Utils/ShaderQQ.hs @@ -55,7 +55,7 @@ -- An explicit example (@@ is from doctest): -- -- >>> let version = 450 :: Int in [glsl|#version $version|] --- "#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line 32 \"\"\n" +-- "#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line 46 \"\"\n" -- -- Note that line number will be thrown off if any of the interpolated -- variables contain newlines. diff --git a/src/Vulkan/Utils/ShaderQQ/Shaderc.hs b/src/Vulkan/Utils/ShaderQQ/Shaderc.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/Shaderc.hs @@ -0,0 +1,285 @@ +module Vulkan.Utils.ShaderQQ.Shaderc + ( hlsl + , comp + , frag + , geom + , tesc + , tese + , vert + , ShadercError + , ShadercWarning + , compileShaderQ + , compileShader + , processShadercMessages + ) where + +import Control.Monad ( void ) +import Control.Monad.IO.Class +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.FileEmbed +import Data.Foldable ( asum ) +import Data.List.Extra +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import System.Exit +import System.IO.Temp +import System.Process.Typed +import Text.ParserCombinators.ReadP +import Vulkan.Utils.ShaderQQ.Interpolate + +-- $setup +-- >>> :set -XQuasiQuotes + +-- | 'hlsl' is a QuasiQuoter which produces HLSL source code with a @#line@ +-- directive inserted so that error locations point to the correct location in +-- the Haskell source file. It also permits basic string interpolation. +-- +-- - Interpolated variables are prefixed with @$@ +-- - They can optionally be surrounded with braces like @${foo}@ +-- - Interpolated variables are converted to strings with 'show' +-- - To escape a @$@ use @\\$@ +-- +-- It is intended to be used in concert with 'compileShaderQ' like so +-- +-- @ +-- myConstant = 3.141 -- Note that this will have to be in a different module +-- myFragmentShader = $(compileShaderQ "frag" [hlsl| +-- static const float myConstant = ${myConstant}; +-- float main (){ +-- return myConstant; +-- } +-- |]) +-- @ +-- +-- An explicit example (@@ is from doctest): +-- +-- >>> let foo = 450 :: Int in [hlsl|const float foo = $foo|] +-- "#line 31 \"\"\nconst float foo = 450" +-- +-- Note that line number will be thrown off if any of the interpolated +-- variables contain newlines. +hlsl :: QuasiQuoter +hlsl = (badQQ "hlsl") + { quoteExp = \s -> do + loc <- location + -- Insert the directive here, `compileShaderQ` will insert + -- another one, but it's before this one, so who cares. + let codeWithLineDirective = insertLineDirective s loc + interpExp codeWithLineDirective + } + +-- | QuasiQuoter for creating a compute shader. +-- +-- Equivalent to calling @$(compileShaderQ "comp" [hlsl|...|])@ without +-- interpolation support. +comp :: QuasiQuoter +comp = shaderQQ "comp" + +-- | QuasiQuoter for creating a fragment shader. +-- +-- Equivalent to calling @$(compileShaderQ "frag" [hlsl|...|])@ without +-- interpolation support. +frag :: QuasiQuoter +frag = shaderQQ "frag" + +-- | QuasiQuoter for creating a geometry shader. +-- +-- Equivalent to calling @$(compileShaderQ "geom" [hlsl|...|])@ without +-- interpolation support. +geom :: QuasiQuoter +geom = shaderQQ "geom" + +-- | QuasiQuoter for creating a tessellation control shader. +-- +-- Equivalent to calling @$(compileShaderQ "tesc" [hlsl|...|])@ without +-- interpolation support. +tesc :: QuasiQuoter +tesc = shaderQQ "tesc" + +-- | QuasiQuoter for creating a tessellation evaluation shader. +-- +-- Equivalent to calling @$(compileShaderQ "tese" [hlsl|...|])@ without +-- interpolation support. +tese :: QuasiQuoter +tese = shaderQQ "tese" + +-- | QuasiQuoter for creating a vertex shader. +-- +-- Equivalent to calling @$(compileShaderQ "vert" [hlsl|...|])@ without +-- interpolation support. +vert :: QuasiQuoter +vert = shaderQQ "vert" + +shaderQQ :: String -> QuasiQuoter +shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ stage } + +-- * Utilities + +-- | Compile a HLSL shader to SPIR-V using glslc (from the shaderc project) +-- +-- Messages are converted to GHC warnings or errors depending on compilation success. +compileShaderQ + :: String + -- ^ stage + -> String + -- ^ glsl or code + -> Q Exp + -- ^ Spir-V bytecode +compileShaderQ stage code = do + loc <- location + (warnings, result) <- compileShader (Just loc) stage code + case warnings of + [] -> pure () + _some -> reportWarning $ prepare warnings + + bs <- case result of + Left [] -> fail "glslc failed with no errors" + Left errors -> do + reportError $ prepare errors + pure mempty + Right bs -> pure bs + + bsToExp bs + + where + prepare [singleLine] = singleLine + prepare multiline = + intercalate "\n" $ "glslc:" : map (mappend " ") multiline + +type ShadercError = String +type ShadercWarning = String + +-- | Compile a HLSL shader to spir-v using glslc +compileShader + :: MonadIO m + => Maybe Loc + -- ^ Source location + -> String + -- ^ stage + -> String + -- ^ HLSL code + -> m ([ShadercWarning], Either [ShadercError] ByteString) + -- ^ Spir-V bytecode with warnings or errors +compileShader loc stage code = + liftIO $ withSystemTempDirectory "th-shader" $ \dir -> do + let codeWithLineDirective = maybe code (insertLineDirective code) loc + let shader = dir <> "/shader.hlsl" + spirv = dir <> "/shader.spv" + writeFile shader codeWithLineDirective + + (rc, out, err) <- readProcess $ proc + "glslc" + ["-fshader-stage=" <> stage, "-x", "hlsl", shader, "-o", spirv] + let (warnings, errors) = processShadercMessages (out <> err) + case rc of + ExitSuccess -> do + bs <- BS.readFile spirv + pure (warnings, Right bs) + ExitFailure _rc -> pure (warnings, Left errors) + +processShadercMessages :: BSL.ByteString -> ([ShadercWarning], [ShadercError]) +processShadercMessages = foldMap parseMsg . lines . BSL.unpack + +-- >>> parseMsg "blah" +-- ([],[]) +-- +-- >>> parseMsg "blah" +-- ([],["blah"]) +-- +-- >>> parseMsg "foo:2: error: unknown var" +-- ([],["foo:2: unknown var"]) +-- +-- >>> parseMsg "foo:2: warning: unknown var" +-- (["foo:2: unknown var"],[]) +-- +-- >>> parseMsg "bar:2: error: 'a' : unknown variable" +-- ([],["bar:2: 'a' : unknown variable"]) +-- +-- >>> parseMsg "f:o: error: f:o:2: 'a' : unknown variable" +-- ([],["f:o:2: 'a' : unknown variable"]) +-- +-- >>> parseMsg "f:o: error: f:o:2: 'return' : type does not match, or is not convertible to, the function's return type" +-- ([],["f:o:2: 'return' : type does not match, or is not convertible to, the function's return type"]) +-- +-- >>> parseMsg "foo: foo(1): error at column 3, HLSL parsing failed." +-- ([],["foo:1: error at column 3, HLSL parsing failed."]) +parseMsg :: String -> ([ShadercWarning], [ShadercError]) +parseMsg = runParser $ foldl1 + (<++) + [ do + f <- filename + line <- between colon colon number + skipSpaces + t <- msgType + msg <- manyTill get eof + pure $ formatMsg t f line msg + , do + f <- filename + colon *> skipSpaces + t <- msgType + _ <- string f + line <- between (char ':') (char ':') number + skipSpaces + msg <- manyTill get eof + pure $ formatMsg t f line msg + , do + f <- filename + colon *> skipSpaces + _ <- string f + line <- between (char '(') (char ')') number + colon *> skipSpaces + let t x = ([], [x]) + msg <- manyTill get eof + pure $ formatMsg t f line msg + , do + _ <- number + skipSpaces + _ <- string "errors generated" + eof + pure ([], []) + , do + -- Unknown format + msg <- manyTill get eof + eof + pure ([], [msg]) + ] + where + formatMsg t f line msg = t (f <> ":" <> show line <> ": " <> msg) + filename = many1 get + number = readS_to_P (reads @Integer) + colon = void $ char ':' + msgType = + asum + [ (\x -> ([], [x])) <$ string "error" + , (\x -> ([x], [])) <$ string "warning" + ] + <* colon + <* skipSpaces + +runParser :: Monoid p => ReadP p -> String -> p +runParser p s = case readP_to_S p s of + [(r, "")] -> r + _ -> mempty + +-- Insert a #line directive with the specified location at the top of the file +insertLineDirective :: String -> Loc -> String +insertLineDirective code Loc {..} = + let lineDirective = + "#line " <> show (fst loc_start) <> " \"" <> loc_filename <> "\"" + in lineDirective <> "\n" <> code + +---------------------------------------------------------------- +-- Utils +---------------------------------------------------------------- + +badQQ :: String -> QuasiQuoter +badQQ name = QuasiQuoter (bad "expression") + (bad "pattern") + (bad "type") + (bad "declaration") + where + bad :: String -> a + bad context = + error $ "Can't use " <> name <> " quote in a " <> context <> " context" diff --git a/vulkan-utils.cabal b/vulkan-utils.cabal --- a/vulkan-utils.cabal +++ b/vulkan-utils.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 2b51403e73e2f406342411ce5b6dd2e2f8db703ba97dd8c135df3d0e3a9b51bc +-- hash: 03fd72b5674b4b85451005687d857d0e9328528b514e5ba805729e54ad6ae761 name: vulkan-utils -version: 0.2 +version: 0.3 synopsis: Utils for the vulkan package category: Graphics homepage: https://github.com/expipiplus1/vulkan#readme @@ -34,6 +34,7 @@ library exposed-modules: + Vulkan.Utils.CommandCheck Vulkan.Utils.Debug Vulkan.Utils.FromGL Vulkan.Utils.Initialization @@ -41,6 +42,7 @@ Vulkan.Utils.QueueAssignment Vulkan.Utils.ShaderQQ Vulkan.Utils.ShaderQQ.Interpolate + Vulkan.Utils.ShaderQQ.Shaderc other-modules: hs-source-dirs: @@ -61,7 +63,7 @@ , transformers , typed-process , vector - , vulkan >=3.6.14 + , vulkan >=3.6.14 && <3.8 default-language: Haskell2010 test-suite doctests