diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright IC Rainbow (c) 2026 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of IC Rainbow nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,73 @@ +# vulkan-utils-spirv + +Generate Haskell data types and Vulkan descriptor-set / pipeline-layout +`*CreateInfo` values from compiled SPIR-V, at compile time, via +[`spirv-reflect`](https://hackage.haskell.org/package/spirv-reflect-ffi) +reflection and [`gl-block`](https://hackage.haskell.org/package/gl-block) +std140/std430 layout. + +## Types from a shader + +A Template Haskell splice generates a record — with a std140/std430 `Storable` +derived via gl-block — for every uniform / storage / push-constant block the +shader declares: + +```haskell +import Vulkan.Utils.SpirV.TH (reflectShaderTypes) + +-- e.g. `Scene { view :: Mat4, lightDir :: Vec3, time :: Float }` (geomancy types), +-- ready to poke straight into a mapped buffer. +reflectShaderTypes "shaders/scene.vert.spv" +``` + +## Pipeline layout from reflection + +`allocateReflectedLayout` merges the descriptor-set layouts and push-constant +ranges across a family of shaders — stage flags OR-ed, shared blocks +cross-checked — into one `PipelineLayout`. `allocateGraphicsPipeline` then builds +each pipeline against it, folding in the vertex stage's reflected vertex input: + +```haskell +import Data.SpirV.Reflect.FFI (loadBytes) +import Vulkan.Utils.DynamicRendering qualified as Dynamic +import Vulkan.Utils.SpirV.Pipeline (allocateGraphicsPipeline, allocateReflectedLayout) +import Vulkan.Zero (zero) + +vertModule <- loadBytes vertSpv +fragModule <- loadBytes fragSpv + +-- one layout for the whole family +(_, layout) <- allocateReflectedLayout dev [vertModule, fragModule] + +(_, pipeline) <- + allocateGraphicsPipeline dev layout + zero{Dynamic.colorFormats = [colorFormat], Dynamic.depthFormat = Just depthFormat} + () -- specialization; () for none + [(vertModule, vertSpv), (fragModule, fragSpv)] +``` + +## Compile-time stage composition + +`reflectStageSig` emits a per-shader signature; `MatchInterface` / +`CompatibleResources` then check — at compile time — that the fragment inputs +match the vertex outputs and that any shared descriptor blocks agree. A mismatch +is a type error, not a validation-layer message at runtime: + +```haskell +import Vulkan.Utils.SpirV.Stage (CompatibleResources, MatchInterface, reflectStageSig) + +reflectStageSig "VertSig" "shaders/scene.vert.spv" +reflectStageSig "FragSig" "shaders/scene.frag.spv" + +-- only type-checks if the two stages compose +pipelineComposes :: (MatchInterface VertSig FragSig, CompatibleResources VertSig FragSig) => Bool +pipelineComposes = True +``` + +## Examples + +Four end-to-end, validation-clean programs under +[`examples/`](../examples): `compute-reflect`, `pathtrace-reflect` (buffer +device address / BVH), `mesh-reflect` (a vertex shader driving a z-prepass and a +shaded pass off one merged layout), and `texture-reflect` (colour-attachment-as- +texture with reflected vertex attributes). diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,79 @@ +name: vulkan-utils-spirv +version: "0.1.0.0" +synopsis: Generate Haskell types and Vulkan descriptor/pipeline layouts from SPIR-V reflection +category: Graphics +maintainer: IC Rainbow +license: BSD-3-Clause +license-file: LICENSE +github: haskell-game/vulkan +extra-source-files: +- README.md +- package.yaml + +library: + source-dirs: src + dependencies: + - base >= 4.16 && <5 + - bytestring + - containers + - gl-block + - ptrdiff + - resourcet + - spirv-enum + - spirv-reflect-ffi + - spirv-reflect-types + - template-haskell + - text + - unliftio-core + - vector + - vulkan >= 3.27 && < 3.28 + - vulkan-utils + +tests: + spec: + main: Spec.hs + source-dirs: test + dependencies: + - base <5 + - bytestring + - containers + - geomancy + - gl-block + - spirv-reflect-ffi + - spirv-reflect-types + - tasty + - tasty-hunit + - template-haskell + - text + - vector + - vulkan + - vulkan-utils + - vulkan-utils-spirv + +ghc-options: +- -Wall + +default-extensions: +- BlockArguments +- DataKinds +- DeriveAnyClass +- DeriveGeneric +- DerivingStrategies +- DerivingVia +- DuplicateRecordFields +- FlexibleContexts +- FlexibleInstances +- ImportQualifiedPost +- LambdaCase +- NamedFieldPuns +- OverloadedRecordDot +- OverloadedStrings +- PatternSynonyms +- RecordWildCards +- ScopedTypeVariables +- StrictData +- TemplateHaskell +- TupleSections +- TypeApplications +- TypeOperators +- ViewPatterns diff --git a/src/Vulkan/Utils/SpirV/Array.hs b/src/Vulkan/Utils/SpirV/Array.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/Array.hs @@ -0,0 +1,198 @@ +-- These extensions are not in the package-wide default-extensions. +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| A fixed-length array suitable as a std140\/std430 block /field/. + +@'Array' n a@ is @n@ elements of @a@ laid out as an array member: each element +occupies a layout-dependent stride (std140 rounds the element stride up to a +multiple of 16; std430 packs to the element's own alignment). The element type's +'Block' instance does the per-element encoding, so anything that is a 'Block' (a +scalar, a vector, or a generated struct record) can be the element. + +The backing 'VS.Vector' should hold exactly @n@ elements; 'write140' \/ 'write430' +write the first @n@ and ignore any extra (so a buffer is never overrun). +-} +module Vulkan.Utils.SpirV.Array + ( Array (..) + , unsafeFromList + , toList + + -- * Runtime-sized arrays + -- $runtime + , std140Stride + , std430Stride + , pokeStd140 + , pokeStd430 + , peekStd140 + , peekStd430 + ) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Proxy (Proxy (..)) +import Data.Vector.Storable qualified as VS +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Ptr.Diff (Diff (..)) +import Foreign.Storable (Storable (..)) +import GHC.TypeNats (KnownNat, Nat, natVal) +import GHC.TypeNats qualified as TN +import Graphics.Gl.Block (Block (..), roundUp) + +-- | @n@ elements of @a@, laid out as an array block member. +newtype Array (n :: Nat) a = Array (VS.Vector a) + +deriving instance (Storable a, Eq a) => Eq (Array n a) +deriving instance (Storable a, Show a) => Show (Array n a) + +-- | Build an 'Array' from a list (should be @n@ elements long). +{-# INLINE unsafeFromList #-} +unsafeFromList :: forall n a. (KnownNat n, Storable a) => [a] -> Array n a +unsafeFromList = Array . VS.fromListN (count (Proxy @n)) + +-- | The elements of an 'Array' as a list. +toList :: (Storable a) => Array n a -> [a] +toList (Array v) = VS.toList v + +{- | A tight, host-side 'Storable' (n contiguous elements). This is unrelated to +the gl-block layout below — it only lets an 'Array' nest as the element of +another 'Array' (multi-dimensional arrays: @'Array' h ('Array' w a)@). +-} +instance (KnownNat n, Storable a) => Storable (Array n a) where + sizeOf _ = count (Proxy @n) * sizeOf (undefined :: a) + alignment _ = alignment (undefined :: a) + peek ptr = Array <$> VS.generateM (count (Proxy @n)) (peekElemOff (castPtr ptr)) + poke ptr (Array v) = VS.imapM_ (pokeElemOff (castPtr ptr)) (VS.take (count (Proxy @n)) v) + +instance (KnownNat n, Block a, Storable a) => Block (Array n a) where + type PackedSize (Array n a) = n TN.* PackedSize a + + isStruct _ = True + + alignment140 _ = lcm 16 (alignment140 (Proxy @a)) + alignment430 _ = alignment430 (Proxy @a) + + sizeOf140 _ = count (Proxy @n) * std140Stride (Proxy @a) + sizeOf430 _ = count (Proxy @n) * std430Stride (Proxy @a) + sizeOfPacked _ = count (Proxy @n) * sizeOfPacked (Proxy @a) + + read140 = readArrayWith (count (Proxy @n)) (std140Stride (Proxy @a)) read140 + read430 = readArrayWith (count (Proxy @n)) (std430Stride (Proxy @a)) read430 + readPacked = readArrayWith (count (Proxy @n)) (sizeOfPacked (Proxy @a)) readPacked + + write140 = writeArrayWith (count (Proxy @n)) (std140Stride (Proxy @a)) write140 + write430 = writeArrayWith (count (Proxy @n)) (std430Stride (Proxy @a)) write430 + writePacked = writeArrayWith (count (Proxy @n)) (sizeOfPacked (Proxy @a)) writePacked + {-# INLINE alignment140 #-} + {-# INLINE alignment430 #-} + {-# INLINE isStruct #-} + {-# INLINE read140 #-} + {-# INLINE read430 #-} + {-# INLINE readPacked #-} + {-# INLINE sizeOf140 #-} + {-# INLINE sizeOf430 #-} + {-# INLINE write140 #-} + {-# INLINE write430 #-} + {-# INLINE writePacked #-} + +{-# INLINE count #-} +count :: (KnownNat n) => Proxy n -> Int +count = fromIntegral . natVal + +{- | Per-element stride for an array member: std140 rounds the element size up to +a multiple of 16. +-} +std140Stride :: (Block a) => Proxy a -> Int +std140Stride p = roundUp (sizeOf140 p) (lcm 16 (alignment140 p)) + +{- | Per-element stride for an array member: std430 packs to the element's own +base alignment. +-} +std430Stride :: (Block a) => Proxy a -> Int +std430Stride p = roundUp (sizeOf430 p) (alignment430 p) + +{- $runtime +A runtime-sized array (the trailing @T[]@ of a storage buffer) has no +compile-time length, so it is /not/ a fixed-size 'Block' and is represented +directly as a @'VS.Vector' a@. These helpers (de)serialize such a vector at the +layout's element stride, using the element's own 'Block' instance — so an element +whose array stride differs from its packed size (e.g. a @vec3@, or a struct +padded up to its alignment) is still placed correctly. The 'Ptr' should point at +the start of the array (for a buffer whose only contents are the array, that is +the mapped base pointer). +-} + +-- | Write a runtime-length array of std140 elements starting at @ptr@. +{-# INLINE pokeStd140 #-} +pokeStd140 :: forall a x m. (Block a, Storable a, MonadIO m) => Ptr x -> VS.Vector a -> m () +pokeStd140 = pokeArrayAt (std140Stride (Proxy @a)) write140 + +-- | Write a runtime-length array of std430 elements starting at @ptr@. +{-# INLINE pokeStd430 #-} +pokeStd430 :: forall a x m. (Block a, Storable a, MonadIO m) => Ptr x -> VS.Vector a -> m () +pokeStd430 = pokeArrayAt (std430Stride (Proxy @a)) write430 + +-- | Read @n@ std140 elements starting at @ptr@. +{-# INLINE peekStd140 #-} +peekStd140 :: forall a x m. (Block a, Storable a, MonadIO m) => Int -> Ptr x -> m (VS.Vector a) +peekStd140 = peekArrayAt (std140Stride (Proxy @a)) read140 + +-- | Read @n@ std430 elements starting at @ptr@. +{-# INLINE peekStd430 #-} +peekStd430 :: forall a x m. (Block a, Storable a, MonadIO m) => Int -> Ptr x -> m (VS.Vector a) +peekStd430 = peekArrayAt (std430Stride (Proxy @a)) read430 + +{-# INLINE pokeArrayAt #-} +pokeArrayAt + :: (Storable a, MonadIO m) + => Int + -> (Ptr x -> Diff x a -> a -> IO ()) + -> Ptr x + -> VS.Vector a + -> m () +pokeArrayAt stride wr ptr v = + liftIO $ VS.imapM_ (\i x -> wr ptr (Diff (i * stride)) x) v + +{-# INLINE peekArrayAt #-} +peekArrayAt + :: (Storable a, MonadIO m) + => Int + -> (Ptr x -> Diff x a -> IO a) + -> Int + -> Ptr x + -> m (VS.Vector a) +peekArrayAt stride rd n ptr = + liftIO $ VS.generateM n (\i -> rd ptr (Diff (i * stride))) + +{-# INLINE readArrayWith #-} +readArrayWith + :: (Storable a, MonadIO m) + => Int + -- ^ element count + -> Int + -- ^ element stride + -> (Ptr x -> Diff x a -> IO a) + -- ^ element reader + -> Ptr x + -> Diff x (Array n a) + -> m (Array n a) +readArrayWith n stride rd ptr (Diff o) = + liftIO $ Array <$> VS.generateM n (\i -> rd ptr (Diff (o + i * stride))) + +{-# INLINE writeArrayWith #-} +writeArrayWith + :: (Storable a, MonadIO m) + => Int + -- ^ element count + -> Int + -- ^ element stride + -> (Ptr x -> Diff x a -> a -> IO ()) + -- ^ element writer + -> Ptr x + -> Diff x (Array n a) + -> Array n a + -> m () +writeArrayWith n stride wr ptr (Diff o) (Array v) = + liftIO $ VS.imapM_ (\i x -> wr ptr (Diff (o + i * stride)) x) (VS.take n v) diff --git a/src/Vulkan/Utils/SpirV/Block.hs b/src/Vulkan/Utils/SpirV/Block.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/Block.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE NoFieldSelectors #-} + +{-| Generate a Haskell record type for a reflected uniform/storage/push-constant +block, deriving its layout from gl-block: @deriving anyclass 'Block'@ (via +"GHC.Generics") plus @deriving 'Storable' via ('Std140' \/ 'Std430')@. + +Splice sites must therefore have @Graphics.Gl.Block (Std140(..), Std430(..))@ in +scope (the @via@ coercion needs the newtype constructor visible) and enable +@DataKinds@ and @TypeFamilies@ (each record also gets a +'Vulkan.Utils.SpirV.Signature.KnownLayout' instance carrying its type-level +layout signature). + +== Guardrail +gl-block's @Generic@ 'Block' instance lays a struct out correctly only when its +field alignments are non-increasing. A lower-aligned field that precedes a +higher-aligned one (e.g. @float@ before @uvec2@) is over-padded and no longer +matches the shader's std140/std430 offsets. Until that is fixed in gl-block, +'structRecordDec' refuses (with a compile error) to generate such a record rather +than emit a silently-wrong layout. +-} +module Vulkan.Utils.SpirV.Block + ( structTypeName + , structRecordDec + , collectStructs + , allMembers16 + ) where + +import Control.Monad (filterM) +import Data.Char (toLower) +import Data.List (intercalate, mapAccumL) +import Data.Maybe (fromMaybe) +import Data.Text qualified as Text +import Data.Vector qualified as V +import Foreign.Storable (Storable) +import GHC.Generics (Generic) +import Graphics.Gl.Block (Block, Std140, Std430) +import Language.Haskell.TH + +import Data.SpirV.Reflect.TypeDescription (TypeDescription) +import Data.SpirV.Reflect.TypeDescription qualified + +import Vulkan.Utils.SpirV.Array (Array) +import Vulkan.Utils.SpirV.DeviceAddress (DeviceAddress) +import Vulkan.Utils.SpirV.Layout (offsetMapOf) +import Vulkan.Utils.SpirV.Signature (knownLayoutInstance) +import Vulkan.Utils.SpirV.Types (LayoutMode (..), NumericType (..), TypeMap, arrayBaseAlign, arrayDims, classifyType, isBdaPointer, leafAlignment, structBaseAlign) + +{- | A block's struct together with every nested and array-element struct +reachable from it, each tagged with the layout to generate it under. This lets +an SSBO array of structs (e.g. @Sphere spheres[]@) yield a record for the +element type even though the wrapping block — a runtime array — isn't itself +representable as a flat record (the caller skips it). +-} +collectStructs :: LayoutMode -> TypeDescription -> [(LayoutMode, TypeDescription)] +collectStructs layout root = snd (go [] root) + where + -- Thread a visited set of SPIR-V ids so a recursive @buffer_reference@ type + -- (a shared DAG / cycle) is collected exactly once rather than unrolled + -- forever — a self-referential @Node@ would otherwise loop here. + go seen td + | maybe False (`elem` seen) td.id = (seen, []) + | otherwise = + let + seen' = maybe seen (: seen) td.id + (seenN, kids) = mapAccumL go seen' (concatMap targets (V.toList td.members)) + in + (seenN, (layout, td) : concat kids) + + -- The struct(s) reachable from a member: an array- or pointer-element struct + -- (via @struct_type_description@), or a directly-nested struct. Leaf members + -- (scalars/vectors/matrices, and device-address pointers) contribute none. + targets m = + case m.struct_type_description of + Just s -> [s] + Nothing + | not (V.null m.members) -> [m] + | otherwise -> [] + +{- | The Haskell type name to generate for an @OpTypeStruct@ 'TypeDescription': +its @type_name@, used verbatim (SPIR-V struct names are already capitalised +Haskell-friendly identifiers). +-} +structTypeName :: TypeDescription -> Maybe String +structTypeName td = case td.type_name of + Just t | not (Text.null t) -> Just (Text.unpack t) + _ -> Nothing + +{- | A classified record field: its name, Haskell type, base alignment (bytes) +under the layout, and whether it is a leaf (scalar/vector/matrix) as opposed to +a nested struct. +-} +data Field = Field + { name :: Name + , type' :: Type + , align :: Int + , leaf :: Bool + } + +{- | Generate the record @data@ declaration for an @OpTypeStruct@, deriving its +'Block' / 'Storable' from gl-block. Returns 'Nothing' if it has no usable name +or a member cannot be represented as a field (e.g. an array — see the +arrays-in-records gap), in which case the caller should skip it. Fails the +splice (guardrail) if the field order would defeat gl-block's std140/std430 +layout. Nested struct members become fields of the corresponding generated +record type. +-} +structRecordDec :: TypeMap -> LayoutMode -> TypeDescription -> Q (Maybe [Dec]) +structRecordDec tymap layout td = + case (structTypeName td, classifiedFields tymap layout (V.toList td.members)) of + (Just nameStr, Just classified) -> + case layoutViolation classified of + Just msg -> + fail $ + "vulkan-utils-spirv: refusing to generate record '" + <> nameStr + <> "': " + <> msg + Nothing -> do + let + tyName = mkName nameStr + recFields = + [ (f.name, Bang NoSourceUnpackedness NoSourceStrictness, f.type') + | f <- classified + ] + wrapper = case layout of + Std140Layout -> ''Std140 + Std430Layout -> ''Std430 + -- Derive @Show@/@Eq@ only when every field type supports them. Some + -- mapped types (e.g. geomancy's @Mat4@) lack @Eq@, and a nested struct + -- field's instances aren't yet visible mid-splice, so a record with a + -- struct field derives neither. + stockExtra <- + if all (.leaf) classified + then filterM (allFieldsAreInstances [f.type' | f <- classified]) [''Show, ''Eq] + else pure [] + let + dataDec = + DataD + [] + tyName + [] + Nothing + [RecC tyName recFields] + [ DerivClause (Just StockStrategy) (ConT ''Generic : map ConT stockExtra) + , DerivClause (Just AnyclassStrategy) [ConT ''Block] + , DerivClause + (Just (ViaStrategy (ConT wrapper `AppT` ConT tyName))) + [ConT ''Storable] + ] + -- Tie a type-level layout signature to the record, computed from + -- the same reflection (the value-level offset map is the oracle). Skipped + -- if the offset map can't be computed (shouldn't happen for a record we + -- already classified). + sigDecs = either (const []) (knownLayoutInstance tyName) (offsetMapOf layout td) + pure (Just (dataDec : sigDecs)) + _ -> pure Nothing + +-- | True when every field type is an instance of the given class. +allFieldsAreInstances :: [Type] -> Name -> Q Bool +allFieldsAreInstances tys cls = and <$> traverse (\t -> isInstance cls [t]) tys + +{- | Classify every member, failing (with 'Nothing') if any cannot be represented +as a record field (e.g. an array member). +-} +classifiedFields :: TypeMap -> LayoutMode -> [TypeDescription] -> Maybe [Field] +classifiedFields tymap layout = traverse $ \mem -> do + fname <- memberFieldName mem + (ty, align, isLeaf) <- fieldOf tymap layout mem + pure Field{name = mkName fname, type' = ty, align, leaf = isLeaf} + +{- | The Haskell type, base alignment and leaf-ness of a single member, or +'Nothing' if it can't be a field (a runtime\/multi-dimensional array, or an +unrecognised type). A fixed-size array becomes an @'Array' n@ field. +-} +fieldOf :: TypeMap -> LayoutMode -> TypeDescription -> Maybe (Type, Int, Bool) +fieldOf tymap layout mem = + case arrayDims mem of + [] -> elementOf tymap layout mem + dims + | all (> 0) dims -> do + -- Fixed-size array (any dimensionality). Multi-dimensional arrays nest: + -- @a[h][w]@ -> @Array h (Array w a)@ (outermost dimension first). + (elemTy, elemAlign, _) <- elementOf tymap layout mem + pure (foldr wrapArray elemTy dims, arrayBaseAlign layout elemAlign, False) + | otherwise -> Nothing -- contains a runtime (0) dimension + where + wrapArray d ty = ConT ''Array `AppT` LitT (NumTyLit (fromIntegral d)) `AppT` ty + +{- | The Haskell type, base alignment and leaf-ness of a member's element type +(i.e. ignoring any array dimensions). +-} +elementOf :: TypeMap -> LayoutMode -> TypeDescription -> Maybe (Type, Int, Bool) +elementOf tymap layout mem + -- A buffer_reference pointer: an 8-byte device address, typed by its pointee + -- record when that is a named struct (else @DeviceAddress ()@). The pointee + -- struct is generated separately by 'collectStructs', not inlined here. The + -- REF check precedes 'classifyType' (a pointer also carries the pointee's leaf + -- flags, e.g. @REF INT@). + | isBdaPointer mem = + -- Reported as non-leaf so the record skips auto-deriving Show/Eq: the + -- pointee (often the record being defined — a self-referential @Node@) is + -- not in scope mid-splice, so probing @Show (DeviceAddress Node)@ would + -- fail, exactly as for a nested-struct field. + let + pointee = mem.struct_type_description >>= structTypeName + arg = maybe (TupleT 0) (ConT . mkName) pointee + in + Just (ConT ''DeviceAddress `AppT` arg, 8, False) + | otherwise = + case classifyType mem of + Just numeric -> do + let numeric' = numeric{array = []} + ty <- tymap numeric' + pure (ty, leafAlignment layout numeric'.scalar numeric'.shape, True) + Nothing -> do + -- A nested struct member: field of the corresponding generated record. + let s = fromMaybe mem mem.struct_type_description + nm <- structTypeName s + align <- structAlignment layout s + pure (ConT (mkName nm), align, False) + +{- | Guardrail: gl-block's 'Generic' layout matches std140/std430 only when field +alignments are non-increasing. Report the first inversion, if any. +-} +layoutViolation :: [Field] -> Maybe String +layoutViolation classified = go [(nameBase f.name, f.align) | f <- classified] + where + go ((n1, a1) : rest@((n2, a2) : _)) + | a1 < a2 = + Just $ + intercalate + " " + [ "field '" <> n1 <> "' (alignment " <> show a1 <> ")" + , "precedes higher-aligned field '" <> n2 <> "' (alignment " <> show a2 <> ");" + , "gl-block's Generic layout would not match std140/std430." + , "Reorder the block's fields by non-increasing alignment" + , "(temporary gl-block limitation)." + ] + | otherwise = go rest + go _ = Nothing + +{- | The base alignment (bytes) of a struct under the given layout: the largest +member alignment, rounded up to 16 for std140. 'Nothing' if any member's +alignment can't be determined. +-} +structAlignment :: LayoutMode -> TypeDescription -> Maybe Int +structAlignment layout td = do + as <- traverse (memberBaseAlignment layout) (V.toList td.members) + pure (structBaseAlign layout as) + +-- | The base alignment of any member (leaf, nested struct, or fixed array). +memberBaseAlignment :: LayoutMode -> TypeDescription -> Maybe Int +memberBaseAlignment layout mem = + case arrayDims mem of + [] -> elementBaseAlignment layout mem + dims + | all (> 0) dims -> arrayBaseAlign layout <$> elementBaseAlignment layout mem + | otherwise -> Nothing + +-- | The base alignment of a member's element type (ignoring array dimensions). +elementBaseAlignment :: LayoutMode -> TypeDescription -> Maybe Int +elementBaseAlignment layout mem + | isBdaPointer mem = Just 8 -- device address: 8-byte scalar + | otherwise = + case classifyType mem of + Just numeric -> Just (leafAlignment layout numeric.scalar numeric.shape) + Nothing -> structAlignment layout (fromMaybe mem mem.struct_type_description) + +{- | True when every member of the struct has 16-byte base alignment. Such a +struct lays out identically under std140 and std430 (same offsets, same size), +so a single generated record can be shared across both layouts ("promotion"). +Anything else used across layouts is rejected by the sharing guardrail. +-} +allMembers16 :: TypeDescription -> Bool +allMembers16 td = not (null ms) && all is16 ms + where + ms = V.toList td.members + is16 m = memberBaseAlignment Std430Layout m == Just 16 + +uncapitalize :: String -> String +uncapitalize [] = [] +uncapitalize (c : cs) = toLower c : cs + +{- | The Haskell record-field name for a reflected member: its declared name, +uncapitalised (SPIR-V capitalises member names, Haskell fields are lower-case). +-} +memberFieldName :: TypeDescription -> Maybe String +memberFieldName = fmap (uncapitalize . Text.unpack) . (.struct_member_name) diff --git a/src/Vulkan/Utils/SpirV/Buffer.hs b/src/Vulkan/Utils/SpirV/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/Buffer.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-| A block of memory tagged with a type-level layout signature. + +A @'Buffer' sig@ is host memory whose byte layout is described by @sig@ (a +'SigOffsetMap' from "Vulkan.Utils.SpirV.Signature"). 'readBuffer' \/ 'writeBuffer' +move whole records in and out, but only for a record whose own layout 'Fits' the +buffer's signature — so a layout mismatch is a /compile/ error, and because +layout-equivalent records share a signature (and 'Fits' accepts a compatible one), +a value written as one record can be read back through any layout-compatible record +(a structural view). + +@ +buf <- 'newBuffer' (MyUbo …) -- Buffer (Sig MyUbo) +view <- 'readBuffer' buf -- any r with Fits (Sig r) (Sig MyUbo) +@ + +The signature is the soundness boundary: 'newBuffer' derives it from the record +it writes (sound by construction); 'unsafeAsBuffer' tags a foreign pointer you +already hold (e.g. VMA @mappedData@) with a signature /you/ assert it satisfies — +that assertion is exactly the reflected buffer's layout. +-} +module Vulkan.Utils.SpirV.Buffer + ( Buffer + , newBuffer + , allocBuffer + , allocArrayBuffer + , readBuffer + , writeBuffer + , readBufferElem + , writeBufferElem + , bufferSize + , withBufferPtr + , unsafeAsBuffer + , unsafeAsBufferPtr + ) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Proxy (Proxy (..)) +import Data.Word (Word8) +import Foreign.ForeignPtr (ForeignPtr, castForeignPtr, mallocForeignPtrBytes, newForeignPtr_, withForeignPtr) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (Storable (..)) + +import Vulkan.Utils.SpirV.Layout qualified -- brings OffsetMap's fields into scope for HasField/ORD +import Vulkan.Utils.SpirV.Signature (Fits, FitsTail, KnownArrayTail, KnownLayout, KnownSigOffsetMap, Sig, SigOffsetMap, arrayTailBaseStride, sigOffsetMapVal) + +-- | Host memory laid out as @sig@. +newtype Buffer (sig :: SigOffsetMap) = Buffer (ForeignPtr Word8) + +-- | Allocate and initialize a buffer from a record, taking its layout signature. +newBuffer :: forall r io. (KnownLayout r, Storable r, MonadIO io) => r -> io (Buffer (Sig r)) +newBuffer r = liftIO $ do + fp <- mallocForeignPtrBytes (sizeOf r) + withForeignPtr fp $ \p -> poke (castPtr p) r + pure (Buffer fp) + +{- | Allocate an uninitialized buffer sized for the (statically-sized) signature +@sig@; use with a type application, e.g. @allocBuffer \@(Sig MyUbo)@. +-} +allocBuffer :: forall sig io. (KnownSigOffsetMap sig, MonadIO io) => io (Buffer sig) +allocBuffer = liftIO $ case sigSize @sig of + Just n -> Buffer <$> mallocForeignPtrBytes n + Nothing -> + ioError (userError "allocBuffer: runtime-sized layout has no static size") + +-- | Read a record out of a buffer, if its layout fits the buffer's signature. +readBuffer :: forall r sig io. (Storable r, Fits (Sig r) sig, MonadIO io) => Buffer sig -> io r +readBuffer (Buffer fp) = liftIO (withForeignPtr fp (peek . castPtr)) + +-- | Write a record into a buffer, if its layout fits the buffer's signature. +writeBuffer :: forall r sig io. (Storable r, Fits (Sig r) sig, MonadIO io) => Buffer sig -> r -> io () +writeBuffer (Buffer fp) r = liftIO (withForeignPtr fp (\p -> poke (castPtr p) r)) + +{- | Allocate a runtime-array buffer (an 'ArrayOf' signature) sized for @n@ +elements: @base + n * stride@ bytes, both taken from the signature's tail. +-} +allocArrayBuffer :: forall sig io. (KnownArrayTail sig, MonadIO io) => Int -> io (Buffer sig) +allocArrayBuffer n = liftIO (Buffer <$> mallocForeignPtrBytes (base + n * stride)) + where + (base, stride) = arrayTailBaseStride @sig + +{- | Read the @i@-th element of a runtime-array buffer (an SSBO @T[]@), if the +record's layout fits the buffer's array tail. The element is at byte offset +@base + i * stride@ taken from the buffer's signature. +-} +readBufferElem :: forall r sig io. (Storable r, FitsTail (Sig r) sig, KnownArrayTail sig, MonadIO io) => Buffer sig -> Int -> io r +readBufferElem (Buffer fp) i = + liftIO (withForeignPtr fp (\p -> peek (castPtr (p `plusPtr` elemOffset @sig i)))) + +{- | Write the @i@-th element of a runtime-array buffer, if the record's layout +fits the buffer's array tail. +-} +writeBufferElem :: forall r sig io. (Storable r, FitsTail (Sig r) sig, KnownArrayTail sig, MonadIO io) => Buffer sig -> Int -> r -> io () +writeBufferElem (Buffer fp) i r = + liftIO (withForeignPtr fp (\p -> poke (castPtr (p `plusPtr` elemOffset @sig i)) r)) + +{- | The byte offset of array element @i@ from the buffer signature's tail. + +'KnownArrayTail' provides the @(base, stride)@ from the type level. +-} +elemOffset :: forall sig. (KnownArrayTail sig) => Int -> Int +elemOffset i = base + i * stride + where + (base, stride) = arrayTailBaseStride @sig + +-- | The buffer's size in bytes, from its signature ('Nothing' if open-ended). +bufferSize :: forall sig. (KnownSigOffsetMap sig) => Buffer sig -> Maybe Int +bufferSize _ = sigSize @sig + +-- | The static byte size of a signature, if it is not runtime-sized. +sigSize :: forall sig. (KnownSigOffsetMap sig) => Maybe Int +sigSize = (sigOffsetMapVal (Proxy @sig)).size + +-- | Run an action on the raw buffer pointer (e.g. to upload to a GPU buffer). +withBufferPtr :: (MonadIO io) => Buffer sig -> (Ptr Word8 -> IO a) -> io a +withBufferPtr (Buffer fp) k = liftIO (withForeignPtr fp k) + +{- | Tag a foreign pointer with a layout signature you assert it satisfies. The +safety obligation is the caller's: @sig@ must match the memory's real layout +(for a reflected GPU buffer, its reflected block layout). +-} +unsafeAsBuffer :: ForeignPtr a -> Buffer sig +unsafeAsBuffer = Buffer . castForeignPtr + +{- | Tag a raw pointer (e.g. VMA @mappedData@) with an asserted layout signature. +The pointer's memory is owned elsewhere — no finalizer is attached, so the +caller must keep it alive for the buffer's lifetime. Same obligation as +'unsafeAsBuffer'. +-} +unsafeAsBufferPtr :: (MonadIO io) => Ptr a -> io (Buffer sig) +unsafeAsBufferPtr p = liftIO (Buffer . castForeignPtr <$> newForeignPtr_ p) diff --git a/src/Vulkan/Utils/SpirV/Descriptors.hs b/src/Vulkan/Utils/SpirV/Descriptors.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/Descriptors.hs @@ -0,0 +1,154 @@ +{-| Build Vulkan descriptor-set-layout and push-constant values from a reflected +'Module' at runtime. The reflected SPIR-V enums share Vulkan's numeric values, so +'Vk.DescriptorType' / 'Vk.ShaderStageFlags' come straight from the reflected +integers. +-} +module Vulkan.Utils.SpirV.Descriptors + ( descriptorSetLayoutInfos + , singleDescriptorSetLayoutInfo + , pushConstantRanges + , pushConstantsSize + , mergedDescriptorSetLayoutInfos + , mergedPushConstantRanges + , moduleStageFlags + ) where + +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Vector qualified as V +import Data.Word (Word32) +import Vulkan.Core10 qualified as Vk +import Vulkan.Zero (zero) + +import Data.SpirV.Reflect.BlockVariable qualified +import Data.SpirV.Reflect.DescriptorBinding qualified as DescriptorBinding +import Data.SpirV.Reflect.DescriptorSet qualified +import Data.SpirV.Reflect.Enums.DescriptorType qualified as R +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified + +import Vulkan.Utils.PipelineLayout (DescriptorBindingConflict (..), mergeDescriptorSetLayoutBindings, mergePushConstantRanges) +import Vulkan.Utils.SpirV.Layout (OffsetMap, mergeKeyed, renderMismatch) +import Vulkan.Utils.SpirV.Reflect.OffsetMaps (pushOffsetMaps, resourceOffsetMaps) + +{- | One @(set number, layout create-info)@ per reflected descriptor set, with +all bindings tagged with this module's shader stage. +-} +descriptorSetLayoutInfos :: Module -> [(Word32, Vk.DescriptorSetLayoutCreateInfo '[])] +descriptorSetLayoutInfos m = + [ ( ds.set + , zero + { Vk.bindings = + V.fromList [bindingToVk stage b | b <- V.toList ds.bindings] + } + ) + | ds <- V.toList m.descriptor_sets + ] + where + stage = moduleStageFlags m + +bindingToVk :: Vk.ShaderStageFlags -> DescriptorBinding.DescriptorBinding -> Vk.DescriptorSetLayoutBinding +bindingToVk stage b = + zero + { Vk.binding = b.binding + , Vk.descriptorType = Vk.DescriptorType (fromIntegral (descriptorTypeInt b)) + , Vk.descriptorCount = fromMaybe 1 b.count + , Vk.stageFlags = stage + } + +{- | The create-info of a module's sole descriptor set — the common single-set +shader. 'Left' if the module declares no sets or more than one. +-} +singleDescriptorSetLayoutInfo :: Module -> Either String (Vk.DescriptorSetLayoutCreateInfo '[]) +singleDescriptorSetLayoutInfo m = + case descriptorSetLayoutInfos m of + [(_, info)] -> Right info + [] -> Left "shader declares no descriptor sets" + sets -> Left ("shader declares " <> show (length sets) <> " descriptor sets, expected exactly one") + +{- | One range per reflected push-constant block, tagged with this module's +shader stage. +-} +pushConstantRanges :: Module -> [Vk.PushConstantRange] +pushConstantRanges m = + [ zero + { Vk.stageFlags = stage + , Vk.offset = pc.absolute_offset + , Vk.size = pc.size + } + | pc <- V.toList m.push_constants + ] + where + stage = moduleStageFlags m + +{- | Total extent of a module's push-constant ranges — the size to pass to +@cmdPushConstants@. + +This is the /reflected/ extent, which is smaller than a generated record's +'Foreign.Storable.sizeOf' whenever std430 trailing-pads the block; pushing the +padded size overruns the declared range. +-} +pushConstantsSize :: Module -> Word32 +pushConstantsSize m = maximum (0 : [r.offset + r.size | r <- pushConstantRanges m]) + +{- | Descriptor set layouts for a /pipeline/ built from several stages: bindings +are collected across all modules and each binding's @stageFlags@ is the OR of the +stages that declare it — correct for a set shared between, say, vertex and +fragment (unlike the single-stage 'descriptorSetLayoutInfos'). + +On top of the generic Vulkan-binding merge ('mergeDescriptorSetLayoutBindings'), +stages sharing a @(set, binding)@ must also agree on its /block layout/ (their +reflected offset maps are unified, see "Vulkan.Utils.SpirV.Layout"). Either a +descriptor-type or a layout disagreement is a 'Left' naming the offending binding. +-} +mergedDescriptorSetLayoutInfos :: [Module] -> Either String [(Word32, Vk.DescriptorSetLayoutCreateInfo '[])] +mergedDescriptorSetLayoutInfos modules = do + verifyKeyed descKey (concatMap resourceOffsetMaps modules) + traverse mergeSet (Map.toAscList bindingsBySet) + where + descKey (s, b) = "descriptor set " <> show s <> " binding " <> show b + + -- set -> the bindings every stage contributes to it (each tagged with its stage). + bindingsBySet :: Map Word32 [Vk.DescriptorSetLayoutBinding] + bindingsBySet = + Map.fromListWith + (flip (++)) + [ (b.set, [bindingToVk (moduleStageFlags m) b]) + | m <- modules + , b <- V.toList m.descriptor_bindings + ] + + mergeSet (setNo, bs) = case mergeDescriptorSetLayoutBindings bs of + Right merged -> Right (setNo, zero{Vk.bindings = V.fromList merged}) + Left c -> + Left (descKey (setNo, c.binding) <> ": descriptor type disagreement between stages") + +{- | Push-constant ranges for a multi-stage pipeline: ranges with the same offset +and size are merged with their stage flags OR-ed. Stages that share a range must +agree on its block layout (the offset maps are unified); a disagreement is a 'Left'. +-} +mergedPushConstantRanges :: [Module] -> Either String [Vk.PushConstantRange] +mergedPushConstantRanges modules = do + verifyKeyed pushKey (concatMap pushOffsetMaps modules) + pure (mergePushConstantRanges (concatMap pushConstantRanges modules)) + where + pushKey (o, sz) = "push constant at offset " <> show o <> " size " <> show sz + +-- | A module's shader stage as a Vulkan flag (SPIR-V shares Vulkan's values). +moduleStageFlags :: Module -> Vk.ShaderStageFlags +moduleStageFlags m = Vk.ShaderStageFlagBits (fromIntegral m.shader_stage) + +-- Layout agreement across stages. ----------------------------------------------- + +{- | Entries sharing a key must unify; the first disagreement is reported with the +key rendered by @shw@. +-} +verifyKeyed :: (Ord k) => (k -> String) -> [(k, OffsetMap)] -> Either String () +verifyKeyed shw entries = case mergeKeyed entries of + Right _ -> Right () + Left (k, mm) -> Left (shw k <> ": " <> renderMismatch mm) + +-- | The reflected descriptor type as its raw integer (Vulkan-compatible). +descriptorTypeInt :: DescriptorBinding.DescriptorBinding -> Int +descriptorTypeInt b = let R.DescriptorType n = b.descriptor_type in n diff --git a/src/Vulkan/Utils/SpirV/DeviceAddress.hs b/src/Vulkan/Utils/SpirV/DeviceAddress.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/DeviceAddress.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +{-| A 64-bit buffer device address — a GPU pointer to a @buffer_reference@ / +@PhysicalStorageBuffer@ block. + +A @buffer_reference@ member of a shader block is stored as an 8-byte address, not +the pointee inline, so reflection-driven codegen maps it to a 'DeviceAddress' +field. The phantom @a@ records the pointee's generated record type (e.g. +@DeviceAddress Node@), purely for documentation and type-safety at the call site; +the runtime representation is just the 'Word64' address. + +The 'Graphics.Gl.Block.Block' instance lays it out as a single 8-byte scalar +(alignment 8) under both std140 and std430 — matching @VkDeviceAddress@ — so a +generated record carrying one gets the right offsets via @deriving Storable via +(Std430 …)@. +-} +module Vulkan.Utils.SpirV.DeviceAddress + ( DeviceAddress (..) + ) where + +import Data.Word (Word64) +import Foreign.Ptr.Diff (peekDiffOff, pokeDiffOff) +import Foreign.Storable (Storable) +import Graphics.Gl.Block (Block (..)) + +-- | A device address pointing at a @buffer_reference@ block of type @a@. +newtype DeviceAddress a = DeviceAddress Word64 + deriving stock (Eq, Ord, Show) + deriving newtype (Storable) + +{- | One 8-byte scalar (alignment 8) under both layouts; mirrors the @Double@ +scalar instance gl-block ships, since @a@ is phantom. +-} +instance Block (DeviceAddress a) where + type PackedSize (DeviceAddress a) = 8 + alignment140 _ = 8 + sizeOf140 = sizeOfPacked + alignment430 = alignment140 + sizeOf430 = sizeOf140 + isStruct _ = False + read140 = peekDiffOff + write140 = pokeDiffOff + read430 = read140 + write430 = write140 + readPacked = read140 + writePacked = write140 diff --git a/src/Vulkan/Utils/SpirV/Layout.hs b/src/Vulkan/Utils/SpirV/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/Layout.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE NoFieldSelectors #-} + +{-| A self-contained, reversible description of a block's memory layout, plus a +value-level unifier over those layouts. + +This is the IR the reflection-driven type machinery is built on. Two levels: + + * 'Layout' \/ 'Member' \/ 'FieldType' — the /structured/ form. It keeps every + member's name, byte offset, and full semantic shape (scalar kind, vector \/ + matrix dimensions, array sizes, nested structs), so it carries enough + information to drive code generation /and/ to be run backwards (e.g. towards + authoring SPIR-V), not merely the flattened offsets. + + * 'OffsetMap' — the /normalized/ form: the flattened offset table of occupied + scalar 'Slot's (each a byte offset + scalar type), plus an optional + runtime-array tail. This is exactly the offset map the GPU sees, so it is the + canonical form for /layout equivalence/: @mat4@, @vec4[4]@ and @float[16]@ + reduce to the same std430 offset map (and correctly diverge under std140, + where the array strides round to 16). This is structural/layout equivalence — + identical normalized bytes — not memory aliasing in the SPIR-V @Aliased@ \/ C + pointer sense. + +'unify' is the compatibility relation: not equality and not a prefix match, but +unification. Two layouts unify when their offset maps can be reconciled (a runtime +tail absorbs a concrete repeat, pinning its length); the result is the +most-defined offset map, which can be folded against further layouts ('foldUnify') +to accumulate a combined picture across pipelines. A failure is reported as a +'Mismatch' with a legible 'renderMismatch'. +-} +module Vulkan.Utils.SpirV.Layout + ( -- * Layout mode + layoutForDescriptor + + -- * Structured layout + , Layout (..) + , Member (..) + , FieldType (..) + , ArraySize (..) + , layoutOf + , fromFields + , leafFieldType + + -- * Normalized offset map + , Slot (..) + , OffsetMap (..) + , RuntimeTail (..) + , normalize + , offsetMapOf + + -- * Unification + , Mismatch (..) + , renderMismatch + , unify + , foldUnify + , mergeKeyed + ) where + +import Data.List (foldl', sortOn) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Vector qualified as V +import Graphics.Gl.Block (roundUp) + +import Data.SpirV.Reflect.Enums.DescriptorType qualified as R +import Data.SpirV.Reflect.TypeDescription (TypeDescription) +import Data.SpirV.Reflect.TypeDescription qualified + +import Vulkan.Utils.SpirV.Types (LayoutMode (..), MemberShape (..), NumericType (..), ScalarType (..), arrayBaseAlign, arrayDims, classifyType, isBdaPointer, leafAlignment, scalarWidth, structBaseAlign) + +{- | The gl-block layout a descriptor's block follows: uniform buffers use +std140, storage buffers std430. Other descriptor types carry no block layout +('Nothing'). +-} +layoutForDescriptor :: R.DescriptorType -> Maybe LayoutMode +layoutForDescriptor = \case + R.DESCRIPTOR_TYPE_UNIFORM_BUFFER -> Just Std140Layout + R.DESCRIPTOR_TYPE_STORAGE_BUFFER -> Just Std430Layout + _ -> Nothing + +{- | A struct's layout under a given 'LayoutMode': its members at their resolved +byte offsets, total size and base alignment. 'size' is 'Nothing' when the struct +ends in a runtime-sized array (its size is not known statically). +-} +data Layout = Layout + { name :: Maybe Text + , mode :: LayoutMode + , members :: [Member] + , size :: Maybe Int + , align :: Int + } + deriving (Eq, Show) + +-- | A struct member: its name, byte offset within the struct, and structured type. +data Member = Member + { name :: Text + , offset :: Int + , type' :: FieldType + } + deriving (Eq, Show) + +{- | The structured type of a member. Multi-dimensional arrays nest +(@'ArrayOf' a ('ArrayOf' b t)@, outermost dimension first). +-} +data FieldType + = Scalar ScalarType + | -- | component count (2..4) + Vector ScalarType Int + | -- | columns, rows + Matrix ScalarType Int Int + | ArrayOf ArraySize FieldType + | Struct Layout + deriving (Eq, Show) + +-- | An array dimension: a fixed length, or a runtime (unsized) trailing array. +data ArraySize = Sized Int | Runtime + deriving (Eq, Show) + +-- Layout arithmetic (std140/std430). -------------------------------------------- + +{- | @(base alignment, size)@ of a field type; size is 'Nothing' for a runtime +array (open). +-} +fieldExtent :: LayoutMode -> FieldType -> (Int, Maybe Int) +fieldExtent mode = \case + Scalar s -> (leafAlignment mode s ShScalar, Just (scalarWidth s)) + Vector s n -> (leafAlignment mode s (ShVector n), Just (n * scalarWidth s)) + Matrix s c r -> + let colStride = leafAlignment mode s (ShMatrix c r) + in (colStride, Just (c * colStride)) + ArrayOf Runtime e -> + let (ea, _) = fieldExtent mode e + in (arrayBaseAlign mode ea, Nothing) + ArrayOf (Sized n) e -> + let + (ea, es) = fieldExtent mode e + align = arrayBaseAlign mode ea + stride = roundUp (fromMaybe 0 es) align + in + (align, Just (n * stride)) + Struct l -> (l.align, l.size) + +{- | The stride between elements of an array of @e@ under the layout. Defined only +when @e@ has a static size (i.e. is not itself a runtime array). +-} +arrayStride :: LayoutMode -> FieldType -> Int +arrayStride mode e = + let (ea, es) = fieldExtent mode e + in roundUp (fromMaybe 0 es) (arrayBaseAlign mode ea) + +-- Building from reflection. ----------------------------------------------------- + +-- | Compute the layout of a reflected @OpTypeStruct@ under the given mode. +layoutOf :: LayoutMode -> TypeDescription -> Either String Layout +layoutOf mode td = do + members <- traverse (memberOf mode) (V.toList td.members) + pure (fromFields mode (structName td) members) + +{- | Build a layout from named fields directly, computing each member's offset +and the struct's size and alignment (no reflection). Besides constructing +expected layouts, this is the direction an authoring front end would use. +-} +fromFields :: LayoutMode -> Maybe Text -> [(Text, FieldType)] -> Layout +fromFields mode name members = + Layout + { name + , mode + , members = [m | (m, _, _) <- placed] + , size = if openEnded then Nothing else Just (roundUp end baseAlign) + , align = baseAlign + } + where + placed = place mode members + baseAlign = structBaseAlign mode [a | (_, a, _) <- placed] + openEnded = any (\(_, _, sz) -> sz == Nothing) placed + end = case reverse placed of + [] -> 0 + ((Member _ off _, _, msz) : _) -> maybe off (off +) msz + +{- | Place members in declaration order, returning each at its offset together +with its alignment and (maybe-open) size. +-} +place :: LayoutMode -> [(Text, FieldType)] -> [(Member, Int, Maybe Int)] +place mode = go 0 + where + go _ [] = [] + go cursor ((nm, ft) : rest) = + let + (align, msz) = fieldExtent mode ft + off = roundUp cursor align + cursor' = maybe off (off +) msz + in + (Member nm off ft, align, msz) : go cursor' rest + +-- | The structured type of a single reflected member. +memberOf :: LayoutMode -> TypeDescription -> Either String (Text, FieldType) +memberOf mode mem = do + nm <- maybe (Left "member without a name") Right mem.struct_member_name + base <- baseFieldType mode mem + let + dims = arrayDims mem + wrap d ft = ArrayOf (if d == 0 then Runtime else Sized (fromIntegral d)) ft + pure (nm, foldr wrap base dims) + +{- | The element type of a member, ignoring array dimensions: a leaf +(scalar\/vector\/matrix) or a nested struct. +-} +baseFieldType :: LayoutMode -> TypeDescription -> Either String FieldType +baseFieldType mode mem + -- A buffer_reference pointer is an 8-byte device address, not the pointee + -- inline; the REF check precedes 'classifyType' because the pointer also + -- carries the pointee's leaf flags (e.g. @REF INT@). + | isBdaPointer mem = Right (Scalar STAddress) + | otherwise = + case classifyType mem of + Just numeric -> Right (leafFieldType numeric) + Nothing -> Struct <$> layoutOf mode (fromMaybe mem mem.struct_type_description) + +leafFieldType :: NumericType -> FieldType +leafFieldType NumericType{scalar, shape} = case shape of + ShScalar -> Scalar scalar + ShVector n -> Vector scalar n + ShMatrix c r -> Matrix scalar c r + +-- Normalization to the scalar offset map. --------------------------------------------- + +-- | One occupied scalar component at a byte offset. +data Slot = Slot + { offset :: Int + , scalar :: ScalarType + } + deriving (Eq, Ord, Show) + +{- | A runtime-sized array tail: a repeating element offset map starting at 'base' +with the given stride. The element 'Slot's are relative to the element start. +-} +data RuntimeTail = RuntimeTail + { base :: Int + , stride :: Int + , element :: [Slot] + } + deriving (Eq, Show) + +{- | A normalized layout: the concrete occupied scalar slots (sorted by offset), +the total size (if statically known), and an optional runtime-array tail. +-} +data OffsetMap = OffsetMap + { slots :: [Slot] + , size :: Maybe Int + , tail :: Maybe RuntimeTail + } + deriving (Eq, Show) + +-- | Flatten a structured 'Layout' to its offset map. +normalize :: Layout -> OffsetMap +normalize l = + OffsetMap + { slots = sortOn (.offset) (concatMap fst pieces) + , size = l.size + , tail = listToMaybe (mapMaybe snd pieces) + } + where + mode = l.mode + pieces = map (flattenMember mode) l.members + +-- | Build the offset map straight from reflection. +offsetMapOf :: LayoutMode -> TypeDescription -> Either String OffsetMap +offsetMapOf mode = fmap normalize . layoutOf mode + +flattenMember :: LayoutMode -> Member -> ([Slot], Maybe RuntimeTail) +flattenMember mode (Member _ off ft) = case ft of + ArrayOf Runtime e -> + ([], Just (RuntimeTail off (arrayStride mode e) (flattenAt mode 0 e))) + _ -> (flattenAt mode off ft, Nothing) + +-- | The scalar slots of a (statically-sized) field type at a base offset. +flattenAt :: LayoutMode -> Int -> FieldType -> [Slot] +flattenAt mode off = \case + Scalar s -> [Slot off s] + Vector s n -> let w = scalarWidth s in [Slot (off + i * w) s | i <- [0 .. n - 1]] + Matrix s c r -> + let + w = scalarWidth s + colStride = leafAlignment mode s (ShMatrix c r) + in + [Slot (off + col * colStride + row * w) s | col <- [0 .. c - 1], row <- [0 .. r - 1]] + ArrayOf (Sized n) e -> + let stride = arrayStride mode e + in concat [flattenAt mode (off + i * stride) e | i <- [0 .. n - 1]] + ArrayOf Runtime _ -> [] -- a runtime array can only be a struct's last member + Struct l -> concatMap (\(Member _ mo mft) -> flattenAt mode (off + mo) mft) l.members + +-- Unification. ------------------------------------------------------------------ + +-- | Why two offset maps fail to unify. +data Mismatch + = -- | differing scalar at a byte offset + SlotMismatch Int ScalarType ScalarType + | -- | differing number of occupied slots + CountMismatch Int Int + | -- | differing total size + SizeMismatch Int Int + | -- | incompatible runtime-array tails + TailMismatch String + deriving (Eq, Show) + +renderMismatch :: Mismatch -> String +renderMismatch = \case + SlotMismatch off l r -> + "scalar mismatch at byte offset " + <> show off + <> ": " + <> showScalar l + <> " vs " + <> showScalar r + CountMismatch l r -> + "different number of components: " <> show l <> " vs " <> show r + SizeMismatch l r -> + "different total size: " <> show l <> " vs " <> show r <> " bytes" + TailMismatch msg -> + "incompatible runtime arrays: " <> msg + where + showScalar STFloat = "float" + showScalar STDouble = "double" + showScalar STInt = "int" + showScalar STUInt = "uint" + showScalar STInt64 = "int64" + showScalar STUInt64 = "uint64" + showScalar STBool = "bool" + showScalar STAddress = "address" + +{- | Unify two offset maps into their most-defined common offset map, or report the first +'Mismatch'. A runtime tail on one side absorbs a matching concrete repeat on +the other (pinning the array length); two closed offset maps must coincide exactly. +-} +unify :: OffsetMap -> OffsetMap -> Either Mismatch OffsetMap +unify a b = case (a.tail, b.tail) of + (Nothing, Nothing) -> do + matchSlots a.slots b.slots + matchSize a.size b.size + pure a + (Just _, Nothing) -> absorb a b + (Nothing, Just _) -> absorb b a + (Just ta, Just tb) -> do + matchSlots a.slots b.slots + if ta == tb + then pure a + else Left (TailMismatch "tails differ in stride, element shape or base offset") + +{- | Reconcile an open offset map (with a runtime tail) against a closed one, requiring +the closed offset map to be the open offset map's prefix followed by whole repeats of its +tail element. Returns the closed (pinned) offset map. +-} +absorb :: OffsetMap -> OffsetMap -> Either Mismatch OffsetMap +absorb open closed = do + let + pre = open.slots + n = length pre + matchSlots pre (take n closed.slots) + let + tl = fromMaybe (error "absorb: open offset map has no tail") open.tail + rest = drop n closed.slots + matchRepeats tl rest + pure closed + +-- | The remaining slots must be zero or more whole repeats of the tail element. +matchRepeats :: RuntimeTail -> [Slot] -> Either Mismatch () +matchRepeats tl = go 0 + where + el = tl.element + m = length el + go _ [] = Right () + go j rest + | length chunk < m = + Left (TailMismatch "trailing bytes are not a whole array element") + | otherwise = do + matchSlots (shift (tl.base + j * tl.stride) el) chunk + go (j + 1) more + where + (chunk, more) = splitAt m rest + shift base = map (\(Slot o s) -> Slot (o + base) s) + +matchSlots :: [Slot] -> [Slot] -> Either Mismatch () +matchSlots xs ys + | length xs /= length ys = Left (CountMismatch (length xs) (length ys)) + | otherwise = + case [ (x.offset, x.scalar, y.scalar) + | (x, y) <- zip xs ys + , x.scalar /= y.scalar || x.offset /= y.offset + ] of + ((off, l, r) : _) -> Left (SlotMismatch off l r) + [] -> Right () + +matchSize :: Maybe Int -> Maybe Int -> Either Mismatch () +matchSize (Just l) (Just r) | l /= r = Left (SizeMismatch l r) +matchSize _ _ = Right () + +{- | Fold a layout against further layouts, accumulating the combined offset map (the +running most-general unifier). Use to add pipelines into a shared layout. +-} +foldUnify :: OffsetMap -> [OffsetMap] -> Either Mismatch OffsetMap +foldUnify = foldl' (\acc g -> acc >>= (`unify` g)) . Right + +{- | Merge layouts tagged by a key (e.g. a @(set, binding)@ or vertex @location@): +entries sharing a key must unify, disjoint keys union in. Reports the offending +key with its 'Mismatch'. +-} +mergeKeyed :: (Ord k) => [(k, OffsetMap)] -> Either (k, Mismatch) (Map k OffsetMap) +mergeKeyed = foldl' step (Right Map.empty) + where + step acc (k, g) = do + m <- acc + case Map.lookup k m of + Nothing -> Right (Map.insert k g m) + Just g' -> case unify g' g of + Right u -> Right (Map.insert k u m) + Left e -> Left (k, e) + +-- | The struct's @type_name@, treating an empty name as absent. +structName :: TypeDescription -> Maybe Text +structName td = td.type_name >>= \t -> if Text.null t then Nothing else Just t diff --git a/src/Vulkan/Utils/SpirV/Pipeline.hs b/src/Vulkan/Utils/SpirV/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/Pipeline.hs @@ -0,0 +1,145 @@ +{-| Build "Vulkan.Utils.Pipeline" bundles from reflected SPIR-V. + +'allocateReflectedLayout' merges a /family/ of shaders into one verified +'Pipeline.Layout' — bindings and push ranges merged across every module, stage +flags OR-ed, shared block layouts cross-checked — shared by every pipeline built +against it. 'allocateGraphicsPipeline' then folds that layout and the vertex +stage's reflected vertex input into "Vulkan.Utils.DynamicRendering"; +'allocateComputePipeline' is the single-stage compute sibling, and +'allocateCompute' collapses the whole family-of-one case into one call. + +The bundles carry their set infos and push ranges, so descriptor sets and pushes +('Pipeline.allocateSet', 'Pipeline.push') track the shaders with nothing +hand-counted. +-} +module Vulkan.Utils.SpirV.Pipeline + ( allocateReflectedLayout + , allocateGraphicsPipeline + , allocateComputePipeline + , allocateCompute + ) where + +import Control.Monad (unless) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Resource (MonadResource, allocate, release) +import Data.ByteString (ByteString) +import Data.List (find) +import Data.Vector qualified as V +import Vulkan.CStruct.Extends (SomeStruct (..)) +import Vulkan.Core10 qualified as Vk +import Vulkan.Zero (zero) + +import Data.SpirV.Reflect.Module (Module) + +import Vulkan.Utils.DynamicRendering qualified as Dynamic +import Vulkan.Utils.Pipeline (Layout, Pipeline (..)) +import Vulkan.Utils.Pipeline qualified as Pipeline +import Vulkan.Utils.Pipeline.Specialization (Specialization) +import Vulkan.Utils.Shader (shaderModuleStage) +import Vulkan.Utils.SpirV.Descriptors (mergedDescriptorSetLayoutInfos, mergedPushConstantRanges, moduleStageFlags) +import Vulkan.Utils.SpirV.Reflect (reflectBytes) +import Vulkan.Utils.SpirV.Specialization (withSpecializationInfo) +import Vulkan.Utils.SpirV.VertexInput (vertexInputState) + +{- | Build the 'Pipeline.Layout' for a family of pipelines from their reflected +modules. Bindings and push-constant ranges are merged across every module — +stage flags OR-ed, shared block layouts cross-checked (see +'mergedDescriptorSetLayoutInfos' / 'mergedPushConstantRanges') — and a conflict +'fail's in @m@. + +Pass every distinct shader the family uses, so the one layout stays compatible +with each pipeline built against it. The layout is owned by @m@'s +'Control.Monad.Trans.Resource.ResourceT' and must outlive the pipelines. +-} +allocateReflectedLayout + :: (MonadResource m, MonadFail m) + => Vk.Device + -> [Module] + -> m Layout +allocateReflectedLayout dev modules = do + setInfos <- orFail (mergedDescriptorSetLayoutInfos modules) + pushRanges <- orFail (mergedPushConstantRanges modules) + sets <- + traverse + (\(setNo, info) -> (,) setNo <$> Pipeline.allocateSetLayout dev info) + setInfos + Pipeline.allocateLayout dev sets pushRanges + where + orFail = either fail pure + +{- | Build one pipeline of a family against a shared 'Layout', folding in both +that layout and the vertex stage's reflected vertex input. + +Each stage is its reflected 'Module' paired with the SPIR-V to compile; the stage +flag is taken from the module. This fills in the config's 'Dynamic.layout' and +'Dynamic.vertexInput' (from the vertex stage's reflection), overwriting any +values set on them; set the per-variant 'Dynamic.colorFormats' \/ +'Dynamic.depthFormat' \/ 'Dynamic.dynamicStates' and vary @spec@ for +specialization. For custom vertex input, drive "Vulkan.Utils.DynamicRendering" +directly and bundle the 'Pipeline' by hand. +-} +allocateGraphicsPipeline + :: (MonadResource m, MonadUnliftIO m, MonadFail m, Specialization spec) + => Vk.Device + -> Layout + -> Dynamic.PipelineConfig + -> spec + -- ^ Specialization shared by every stage; @()@ for none. + -> [(Module, ByteString)] + -- ^ Each stage's reflected module and the SPIR-V to compile. + -> m Pipeline +allocateGraphicsPipeline dev layout config spec stages = do + (_, pipeline) <- + Dynamic.allocatePipelineFromShaders + dev + config + { Dynamic.layout = Just layout.pipelineLayout + , Dynamic.vertexInput = maybe zero vertexInputState vertexModule + } + spec + [(moduleStageFlags m, spv) | (m, spv) <- stages] + pure Pipeline{pipeline, bindPoint = Vk.PIPELINE_BIND_POINT_GRAPHICS, layout} + where + vertexModule = fst <$> find (\(m, _) -> moduleStageFlags m == Vk.SHADER_STAGE_VERTEX_BIT) stages + +{- | The compute sibling of 'allocateGraphicsPipeline': one compute stage built +against a shared 'Layout'. + +Specialization constants are packed against the module's reflected +@constant_id@s (see "Vulkan.Utils.SpirV.Specialization"); pass @()@ for none. +-} +allocateComputePipeline + :: (MonadResource m, MonadUnliftIO m, MonadFail m, Specialization spec) + => Vk.Device + -> Layout + -> spec + -> (Module, ByteString) + -- ^ The compute stage's reflected module and the SPIR-V to compile. + -> m Pipeline +allocateComputePipeline dev layout spec (m, spv) = do + unless (moduleStageFlags m == Vk.SHADER_STAGE_COMPUTE_BIT) $ + fail "allocateComputePipeline: the module is not a compute shader" + withSpecializationInfo m spec $ \specInfo -> do + (stageKey, stage) <- shaderModuleStage dev Vk.SHADER_STAGE_COMPUTE_BIT specInfo spv + let createInfo = zero{Vk.layout = layout.pipelineLayout, Vk.stage = stage} :: Vk.ComputePipelineCreateInfo '[] + (_, (_, pipelines)) <- Vk.withComputePipelines dev zero (V.singleton (SomeStruct createInfo)) Nothing allocate + release stageKey + pure Pipeline{pipeline = V.head pipelines, bindPoint = Vk.PIPELINE_BIND_POINT_COMPUTE, layout} + +{- | Reflect → layout → pipeline, in one call. + +The family-of-one case: the shader's SPIR-V is reflected here and the layout is +its alone. For pipelines sharing a layout across shaders, compose +'allocateReflectedLayout' with 'allocateComputePipeline'. +-} +allocateCompute + :: (MonadResource m, MonadUnliftIO m, MonadFail m, Specialization spec) + => Vk.Device + -> spec + -> ByteString + -- ^ The compute stage's SPIR-V. + -> m Pipeline +allocateCompute dev spec code = do + reflected <- reflectBytes code + layout <- allocateReflectedLayout dev [reflected] + allocateComputePipeline dev layout spec (reflected, code) diff --git a/src/Vulkan/Utils/SpirV/Reflect.hs b/src/Vulkan/Utils/SpirV/Reflect.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/Reflect.hs @@ -0,0 +1,32 @@ +{-| Reflect compiled SPIR-V into a 'Module', both at runtime and inside +Template Haskell splices. +-} +module Vulkan.Utils.SpirV.Reflect + ( Module + , reflectFile + , reflectBytes + , reflectFileQ + ) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString (ByteString) +import Language.Haskell.TH.Syntax (Q, addDependentFile, runIO) + +import Data.SpirV.Reflect.FFI (load, loadBytes) +import Data.SpirV.Reflect.Module (Module) + +-- | Reflect a @.spv@ file into a 'Module'. +reflectFile :: (MonadIO m) => FilePath -> m Module +reflectFile = load + +-- | Reflect SPIR-V bytecode into a 'Module'. +reflectBytes :: (MonadIO m) => ByteString -> m Module +reflectBytes = loadBytes + +{- | Reflect a @.spv@ file at compile time, registering it as a dependency so +the splice is rerun when the file changes. +-} +reflectFileQ :: FilePath -> Q Module +reflectFileQ path = do + addDependentFile path + runIO $ reflectFile path diff --git a/src/Vulkan/Utils/SpirV/Reflect/OffsetMaps.hs b/src/Vulkan/Utils/SpirV/Reflect/OffsetMaps.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/Reflect/OffsetMaps.hs @@ -0,0 +1,57 @@ +{-| Extract normalized 'OffsetMap's from a reflected 'Module''s resources. + +Both the runtime descriptor/push-constant builders +("Vulkan.Utils.SpirV.Descriptors") and the compile-time stage-signature +machinery ("Vulkan.Utils.SpirV.Stage") need the same thing: the std140\/std430 +'OffsetMap' of each buffer-typed descriptor binding and of each push-constant block. +That extraction — pick the layout mode from the descriptor type, pull the block +'TypeDescription', run 'offsetMapOf' — lives here once so the two callers can't drift. +-} +module Vulkan.Utils.SpirV.Reflect.OffsetMaps + ( resourceOffsetMap + , resourceOffsetMaps + , pushOffsetMap + , pushOffsetMaps + ) where + +import Data.Maybe (mapMaybe) +import Data.Vector qualified as V +import Data.Word (Word32) + +import Data.SpirV.Reflect.BlockVariable (BlockVariable) +import Data.SpirV.Reflect.BlockVariable qualified +import Data.SpirV.Reflect.DescriptorBinding (DescriptorBinding) +import Data.SpirV.Reflect.DescriptorBinding qualified +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified + +import Vulkan.Utils.SpirV.Layout (OffsetMap, layoutForDescriptor, offsetMapOf) +import Vulkan.Utils.SpirV.Types (LayoutMode (..)) + +{- | The @((set, binding), offset map)@ of a single buffer-typed descriptor +binding. 'Nothing' for non-buffer descriptors (samplers, images, …) and for blocks +whose offset map can't be computed. +-} +resourceOffsetMap :: DescriptorBinding -> Maybe ((Word32, Word32), OffsetMap) +resourceOffsetMap b = do + mode <- layoutForDescriptor b.descriptor_type + td <- b.type_description + g <- eitherToMaybe (offsetMapOf mode td) + pure ((b.set, b.binding), g) + +-- | The reflected block offset map of each buffer-typed binding, keyed by @(set, binding)@. +resourceOffsetMaps :: Module -> [((Word32, Word32), OffsetMap)] +resourceOffsetMaps = mapMaybe resourceOffsetMap . V.toList . (.descriptor_bindings) + +-- | The std430 offset map of a push-constant block, if it can be computed. +pushOffsetMap :: BlockVariable -> Maybe OffsetMap +pushOffsetMap pc = pc.type_description >>= eitherToMaybe . offsetMapOf Std430Layout + +-- | The reflected offset map of each push-constant block, keyed by @(offset, size)@. +pushOffsetMaps :: Module -> [((Word32, Word32), OffsetMap)] +pushOffsetMaps = mapMaybe keyed . V.toList . (.push_constants) + where + keyed pc = (,) (pc.absolute_offset, pc.size) <$> pushOffsetMap pc + +eitherToMaybe :: Either e a -> Maybe a +eitherToMaybe = either (const Nothing) Just diff --git a/src/Vulkan/Utils/SpirV/Signature.hs b/src/Vulkan/Utils/SpirV/Signature.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/Signature.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +{-| Type-level layout signatures, tied to the records reflection generates. + +Each generated block record carries a ground 'SigOffsetMap' — the promotion of its +normalized 'OffsetMap' ("Vulkan.Utils.SpirV.Layout"), computed value-level at splice +time (the value-level layout is the oracle; see 'knownLayoutInstance'). Because +the offset map is /normalized/ before promotion, layout-equivalent layouts — +@mat4@, @vec4[4]@, @float[16]@ under std430 — promote to the /same/ 'SigOffsetMap', +so the type-level matcher 'Fits' accepts them with no special cases. + +'Fits' is intentionally thin: a use-site /matcher/ against an already-ground +signature, not a unifier (the heavy unification stays value-level in @Q@). The +ground offset map can be reflected back to a value with 'layoutSig' \/ +'sigOffsetMapVal', which is how the type level is validated against the value-level +unifier. +-} +module Vulkan.Utils.SpirV.Signature + ( -- * Type-level offset map + SigOffsetMap (..) + , SigSlot (..) + , SigTail (..) + + -- * Records carrying a signature + , KnownLayout (..) + , layoutSig + + -- * Reflecting a signature back to a value + , KnownSigOffsetMap (..) + , KnownArrayTail (..) + , KnownMaybeSig (..) + , KnownKeyedSigs (..) + + -- * Matching + , Fits + , FitsTail + , ArrayOf + + -- * Generation (Template Haskell) + , knownLayoutInstance + , promoteOffsetMap + , promoteList + , promoteMaybe + , natT + ) where + +import Data.Kind (Constraint) +import Data.Proxy (Proxy (..)) +import Data.Word (Word32) +import GHC.TypeLits (ErrorMessage (..), KnownNat, Nat, TypeError, natVal) +import Language.Haskell.TH + +import Vulkan.Utils.SpirV.Layout (OffsetMap (..), RuntimeTail (..), Slot (..)) +import Vulkan.Utils.SpirV.Types (ScalarType (..)) + +-- | One occupied scalar component at a byte offset (type-level mirror of 'Slot'). +data SigSlot = SigSlot Nat ScalarType + +{- | A runtime-array tail (mirror of 'RuntimeTail'): base offset, stride, and the +element's slots (relative to the element start). +-} +data SigTail = SigTail Nat Nat [SigSlot] + +{- | A normalized layout at the type level (mirror of 'OffsetMap'): concrete slots, the +total size if statically known, and an optional runtime-array tail. +-} +data SigOffsetMap = SigOffsetMap [SigSlot] (Maybe Nat) (Maybe SigTail) + +{- | A Haskell type with a ground, reflection-derived layout signature. Generated +records get an instance via 'knownLayoutInstance'. +-} +class (KnownSigOffsetMap (Sig a)) => KnownLayout a where + type Sig a :: SigOffsetMap + +-- | The value-level normal form of a record's signature (the oracle view). +layoutSig :: forall a. (KnownLayout a) => OffsetMap +layoutSig = sigOffsetMapVal (Proxy @(Sig a)) + +-- Reflection: type-level offset map -> value 'OffsetMap'. ---------------------------------- + +class KnownScalar (s :: ScalarType) where + scalarVal :: Proxy s -> ScalarType + +instance KnownScalar 'STFloat where scalarVal _ = STFloat +instance KnownScalar 'STDouble where scalarVal _ = STDouble +instance KnownScalar 'STInt where scalarVal _ = STInt +instance KnownScalar 'STUInt where scalarVal _ = STUInt +instance KnownScalar 'STInt64 where scalarVal _ = STInt64 +instance KnownScalar 'STUInt64 where scalarVal _ = STUInt64 +instance KnownScalar 'STBool where scalarVal _ = STBool +instance KnownScalar 'STAddress where scalarVal _ = STAddress + +class KnownSlots (xs :: [SigSlot]) where + slotsVal :: Proxy xs -> [Slot] + +instance KnownSlots '[] where + slotsVal _ = [] + +instance (KnownNat o, KnownScalar s, KnownSlots rest) => KnownSlots ('SigSlot o s ': rest) where + slotsVal _ = + Slot (fromIntegral (natVal (Proxy @o))) (scalarVal (Proxy @s)) : slotsVal (Proxy @rest) + +class KnownMaybeNat (m :: Maybe Nat) where + maybeNatVal :: Proxy m -> Maybe Int + +instance KnownMaybeNat 'Nothing where + maybeNatVal _ = Nothing + +instance (KnownNat n) => KnownMaybeNat ('Just n) where + maybeNatVal _ = Just (fromIntegral (natVal (Proxy @n))) + +class KnownTail (t :: SigTail) where + tailVal :: Proxy t -> RuntimeTail + +instance (KnownNat b, KnownNat s, KnownSlots es) => KnownTail ('SigTail b s es) where + tailVal _ = + RuntimeTail + (fromIntegral (natVal (Proxy @b))) + (fromIntegral (natVal (Proxy @s))) + (slotsVal (Proxy @es)) + +class KnownMaybeTail (m :: Maybe SigTail) where + maybeTailVal :: Proxy m -> Maybe RuntimeTail + +instance KnownMaybeTail 'Nothing where + maybeTailVal _ = Nothing + +instance (KnownTail t) => KnownMaybeTail ('Just t) where + maybeTailVal _ = Just (tailVal (Proxy @t)) + +-- | Reflect a ground type-level offset map back to its value form. +class KnownSigOffsetMap (g :: SigOffsetMap) where + sigOffsetMapVal :: Proxy g -> OffsetMap + +instance (KnownSlots ss, KnownMaybeNat sz, KnownMaybeTail tl) => KnownSigOffsetMap ('SigOffsetMap ss sz tl) where + sigOffsetMapVal _ = + OffsetMap (slotsVal (Proxy @ss)) (maybeNatVal (Proxy @sz)) (maybeTailVal (Proxy @tl)) + +{- | The @(base offset, element stride)@ of a buffer signature's runtime-array +tail, recovered straight from the type level. Only a layout that /has/ a tail has +an instance, so reading it is total — and unlike reflecting the whole 'OffsetMap' and +inspecting its 'Maybe' tail ('sigOffsetMapVal'), it forces only the two 'Nat's it +needs, not the element's slot list. So an element loop pays @O(1)@ per element, +not @O(offset map)@. +-} +class KnownArrayTail (t :: SigOffsetMap) where + arrayTailBaseStride :: (Int, Int) + +instance (KnownNat base, KnownNat stride) => KnownArrayTail ('SigOffsetMap cs csz ('Just ('SigTail base stride es))) where + arrayTailBaseStride = + (fromIntegral (natVal (Proxy @base)), fromIntegral (natVal (Proxy @stride))) + +-- | Reflect an optional ground offset map (e.g. a push-constant layout) back to a value. +class KnownMaybeSig (m :: Maybe SigOffsetMap) where + maybeSigVal :: Proxy m -> Maybe OffsetMap + +instance KnownMaybeSig 'Nothing where + maybeSigVal _ = Nothing + +instance (KnownSigOffsetMap g) => KnownMaybeSig ('Just g) where + maybeSigVal _ = Just (sigOffsetMapVal (Proxy @g)) + +-- | Reflect a list of @((set, binding), offset map)@ entries back to values. +class KnownKeyedSigs (xs :: [((Nat, Nat), SigOffsetMap)]) where + keyedSigsVal :: Proxy xs -> [((Word32, Word32), OffsetMap)] + +instance KnownKeyedSigs '[] where + keyedSigsVal _ = [] + +instance + (KnownNat s, KnownNat b, KnownSigOffsetMap g, KnownKeyedSigs rest) + => KnownKeyedSigs ('( '(s, b), g) ': rest) + where + keyedSigsVal _ = + ((nat32 (Proxy @s), nat32 (Proxy @b)), sigOffsetMapVal (Proxy @g)) + : keyedSigsVal (Proxy @rest) + +nat32 :: (KnownNat n) => Proxy n -> Word32 +nat32 = fromIntegral . natVal + +-- Matching. --------------------------------------------------------------------- + +{- | The use-site matcher: @'Fits' r t@ holds when a value of layout @r@ may be +viewed at a slot of layout @t@. Since both are normalized before promotion, +layout-equivalent layouts share a signature and match by equality; a difference is +a legible compile error. (Runtime-tail absorption is handled value-level when a +buffer's signature is built; this matcher covers the ground case.) +-} +type family Fits (r :: SigOffsetMap) (t :: SigOffsetMap) :: Constraint where + Fits g g = () + Fits r t = + TypeError + ( 'Text "Layout mismatch." + ':$$: 'Text " have: " + ':<>: 'ShowType r + ':$$: 'Text " want: " + ':<>: 'ShowType t + ) + +{- | The signature of a tightly-packed runtime array @r[]@ — an SSBO whose content +is a runtime array of the element layout @r@. The element becomes the array +tail: its (statically known) size is the stride, the base offset is 0, and the +closed slots clear. Use to tag a mapped SSBO pointer, e.g. +@'Vulkan.Utils.SpirV.Buffer.unsafeAsBufferPtr' p :: io (Buffer ('ArrayOf' ('Sig' Vertex)))@. +(The element's std430 standalone size equals its array stride, so this is exact +for a tightly-packed @T[]@.) +-} +type family ArrayOf (r :: SigOffsetMap) :: SigOffsetMap where + ArrayOf ('SigOffsetMap slots ('Just size) 'Nothing) = + 'SigOffsetMap '[] 'Nothing ('Just ('SigTail 0 size slots)) + ArrayOf r = + TypeError + ( 'Text "ArrayOf: the element layout must be statically sized and not itself open:" + ':$$: 'Text " " + ':<>: 'ShowType r + ) + +{- | @'FitsTail' r t@ holds when a record of layout @r@ is one element of the +runtime-array tail of buffer layout @t@: @r@ is closed with a known size equal +to the tail stride, and its slots are exactly the tail element's. Layout-equivalent +element records share a signature, so they match too; a mismatch (or a @t@ +without a tail) is a legible compile error. +-} +type family FitsTail (r :: SigOffsetMap) (t :: SigOffsetMap) :: Constraint where + FitsTail ('SigOffsetMap es ('Just sz) 'Nothing) ('SigOffsetMap _ _ ('Just ('SigTail _ sz es))) = () + FitsTail r t = + TypeError + ( 'Text "Element layout does not fit the buffer's array tail." + ':$$: 'Text " element: " + ':<>: 'ShowType r + ':$$: 'Text " buffer: " + ':<>: 'ShowType t + ) + +-- Generation. ------------------------------------------------------------------- + +{- | Emit @instance 'KnownLayout' where type 'Sig' = @, promoting the value-level normal form to the type level. +-} +knownLayoutInstance :: Name -> OffsetMap -> [Dec] +knownLayoutInstance name om = + [ InstanceD + Nothing + [] + (ConT ''KnownLayout `AppT` ConT name) + [TySynInstD (TySynEqn Nothing (ConT ''Sig `AppT` ConT name) (promoteOffsetMap om))] + ] + +promoteOffsetMap :: OffsetMap -> Type +promoteOffsetMap (OffsetMap slots msize mtail) = + PromotedT 'SigOffsetMap + `AppT` promoteSlots slots + `AppT` promoteMaybe natT msize + `AppT` promoteMaybe promoteTail mtail + +promoteTail :: RuntimeTail -> Type +promoteTail (RuntimeTail base stride es) = + PromotedT 'SigTail `AppT` natT base `AppT` natT stride `AppT` promoteSlots es + +promoteSlots :: [Slot] -> Type +promoteSlots = promoteList promoteSlot + +promoteSlot :: Slot -> Type +promoteSlot (Slot off sc) = + PromotedT 'SigSlot `AppT` natT off `AppT` PromotedT (scalarName sc) + +-- | Promote a list, element-wise, to a promoted @'[..]@. +promoteList :: (a -> Type) -> [a] -> Type +promoteList f = foldr (\x acc -> PromotedConsT `AppT` f x `AppT` acc) PromotedNilT + +-- | Promote a 'Maybe' to a promoted @'Nothing@ \/ @'Just@. +promoteMaybe :: (a -> Type) -> Maybe a -> Type +promoteMaybe _ Nothing = PromotedT 'Nothing +promoteMaybe f (Just x) = PromotedT 'Just `AppT` f x + +-- | An integral value as a type-level 'Nat' literal. +natT :: (Integral a) => a -> Type +natT = LitT . NumTyLit . fromIntegral + +scalarName :: ScalarType -> Name +scalarName = \case + STFloat -> 'STFloat + STDouble -> 'STDouble + STInt -> 'STInt + STUInt -> 'STUInt + STInt64 -> 'STInt64 + STUInt64 -> 'STUInt64 + STBool -> 'STBool + STAddress -> 'STAddress diff --git a/src/Vulkan/Utils/SpirV/Specialization.hs b/src/Vulkan/Utils/SpirV/Specialization.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/Specialization.hs @@ -0,0 +1,145 @@ +{-| Build Vulkan specialization-constant values from a reflected 'Module'. + +Reflection yields each constant's @constant_id@ and name but not its type or +width, and the value side (the 'Specialization' class) is a stack of 'Word32's — +so only 32-bit scalar constants (@int@\/@uint@\/@float@\/@bool@, the +@GL_KHR_vulkan_glsl@ baseline) are supported, one 4-byte slot each. +'specializationMapEntries' lays them out in ascending @constant_id@ order (the +ids need not be contiguous). Wider constants are out of scope (see +@spirv-cleanup.md@); a 64-bit value supplied as two 'Word32's trips 'packed'\'s +arity check rather than being silently truncated. + +Supply the values via the 'Specialization' class from +"Vulkan.Utils.Pipeline.Specialization", in ascending @constant_id@ order. (That +module shares the 32-bit limit and additionally assumes @constantID = offset \/ 4@.) +-} +module Vulkan.Utils.SpirV.Specialization + ( specializationConstants + , specializationMapEntries + , withSpecializationInfo + , allocateSpecializationInfo + ) where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) +import Control.Monad.Trans.Resource (MonadResource, allocate) +import Data.List (sortOn) +import Data.Text (Text) +import Data.Vector (Vector) +import Data.Vector qualified as V +import Data.Vector.Storable qualified as VS +import Data.Word (Word32) +import Foreign.Marshal.Alloc (free) +import Foreign.Marshal.Array (mallocArray, pokeArray) +import Foreign.Ptr (Ptr, castPtr) +import Vulkan.Core10 qualified as Vk +import Vulkan.Utils.Pipeline.Specialization (Specialization (..)) + +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified as Module +import Data.SpirV.Reflect.SpecializationConstant qualified as SC + +-- | Reflected specialization constants as @(constant_id, name)@, ascending by id. +specializationConstants :: Module -> [(Word32, Maybe Text)] +specializationConstants m = + sortOn fst [(scId c, scName c) | c <- V.toList (moduleSpecConstants m)] + +{- | One tightly-packed 32-bit map entry per reflected spec constant, ascending +by @constant_id@ (offset @= index * 4@, size 4). +-} +specializationMapEntries :: Module -> Vector Vk.SpecializationMapEntry +specializationMapEntries m = + V.fromList + [ Vk.SpecializationMapEntry + { Vk.constantID = cid + , Vk.offset = fromIntegral (ix * 4) + , Vk.size = 4 + } + | (ix, (cid, _)) <- zip [0 :: Int ..] (specializationConstants m) + ] + +{- | Pack a 'Specialization' against the reflected map entries, yielding a +'Vk.SpecializationInfo' valid for the callback's duration (pipeline creation +copies the values out — build and create the pipeline inside the callback). +'Nothing' when the shader declares no spec constants. + +The supplied values must be in ascending @constant_id@ order and number the +shader's declared constants; a mismatch is a programmer error and 'error's. +-} +withSpecializationInfo + :: (Specialization spec, MonadUnliftIO m) + => Module + -> spec + -> (Maybe Vk.SpecializationInfo -> m a) + -> m a +withSpecializationInfo m spec action = + case packed m spec of + Nothing -> action Nothing + Just (entries, ws) -> + withRunInIO $ \run -> + VS.unsafeWith (VS.fromList ws) $ \p -> + run . action $ Just (specInfo entries (length ws) (castPtr p)) + +{- | As 'withSpecializationInfo', but the backing buffer lives until the +surrounding 'Control.Monad.Trans.Resource.ResourceT' scope ends rather than a +callback — so it survives a later pipeline creation. 'Nothing' when the shader +declares no spec constants. +-} +allocateSpecializationInfo + :: (Specialization spec, MonadResource m) + => Module + -> spec + -> m (Maybe Vk.SpecializationInfo) +allocateSpecializationInfo m spec = + case packed m spec of + Nothing -> pure Nothing + Just (entries, ws) -> do + let n = length ws + -- A C-malloc'd buffer is pointer-stable and freed at scope end; the + -- pointer must stay valid until pipeline creation copies the values. + (_key, ptr) <- allocate (mallocArray n) free + liftIO $ pokeArray ptr ws + pure $ Just (specInfo entries n (castPtr ptr)) + +{- | Reflected map entries paired with the caller's packed values, or 'Nothing' +when there are no spec constants. 'error's on an arity mismatch. +-} +packed + :: (Specialization spec) + => Module + -> spec + -> Maybe (Vector Vk.SpecializationMapEntry, [Word32]) +packed m spec + | V.null entries = Nothing + | length ws /= n = + error $ + "Vulkan.Utils.SpirV.Specialization: shader declares " + <> show n + <> " specialization constant(s) but " + <> show (length ws) + <> " value(s) were supplied" + | otherwise = Just (entries, ws) + where + entries = specializationMapEntries m + n = V.length entries + ws = specializationData spec + +specInfo :: Vector Vk.SpecializationMapEntry -> Int -> Ptr () -> Vk.SpecializationInfo +specInfo entries n p = + Vk.SpecializationInfo + { Vk.mapEntries = entries + , Vk.dataSize = fromIntegral (n * 4) + , Vk.data' = p + } + +-- Field accessors via record patterns (the constructor disambiguates the +-- DuplicateRecordFields names). + +moduleSpecConstants :: Module -> Vector SC.SpecializationConstant +moduleSpecConstants Module.Module{Module.spec_constants = cs} = cs + +scId :: SC.SpecializationConstant -> Word32 +scId SC.SpecializationConstant{SC.constant_id = i} = i + +scName :: SC.SpecializationConstant -> Maybe Text +scName SC.SpecializationConstant{SC.name = n} = n diff --git a/src/Vulkan/Utils/SpirV/Stage.hs b/src/Vulkan/Utils/SpirV/Stage.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/Stage.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoFieldSelectors #-} + +{-| Per-shader /stage signatures/ and the type-level checks that compose them. + +A 'ShaderSig' captures, at the type level, a shader stage's interface (its @in@ +and @out@ variables, by location) and its resource layouts (descriptor blocks by +@(set, binding)@, and push constants) — each as a normalized 'SigOffsetMap' +("Vulkan.Utils.SpirV.Signature"). 'reflectStageSig' emits one from a compiled +@.spv@; the value-level 'StageInfo' it is promoted from is also returned by +'stageInfoOf' for use as the oracle and for building Vulkan create-infos. + +The composition checks are thin type-level /matchers/ (the heavy work stayed +value-level): 'MatchInterface' requires every fragment input to have a +matching-typed vertex output at the same location. + +'reflectPipelineLayoutSig' goes one step further: it promotes the /merged/ +pipeline-layout signature (descriptor blocks by @(set, binding)@ + push) across a +family of shaders — the type-level counterpart of the runtime merge in +"Vulkan.Utils.SpirV.Descriptors". +-} +module Vulkan.Utils.SpirV.Stage + ( -- * Stage signatures + ShaderSig (..) + , StageKind (..) + + -- * Value-level extraction (the oracle) + , StageInfo (..) + , stageInfoOf + , matchInterface + , Linked (..) + , linkStages + + -- * Type-level checks + , MatchInterface + , CompatibleResources + + -- * Merged pipeline-layout signature + , LayoutSig (..) + , LayoutInfo (..) + , mergeLayout + , KnownLayoutSig (..) + + -- * Generation + , reflectStageSig + , reflectStageSigBytes + , reflectPipelineLayoutSig + , reflectPipelineLayoutSigBytes + ) where + +import Data.ByteString (ByteString) +import Data.Kind (Constraint) +import Data.List (foldl', sortOn) +import Data.Proxy (Proxy (..)) +import Data.Vector qualified as V +import Data.Word (Word32) +import GHC.TypeLits (ErrorMessage (..), Nat, TypeError) +import Language.Haskell.TH + +import Data.SpirV.Enum (BuiltIn (..)) +import Data.SpirV.Reflect.InterfaceVariable qualified as InterfaceVariable +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified +import Data.SpirV.Reflect.TypeDescription (TypeDescription) + +import Vulkan.Utils.SpirV.Layout (OffsetMap, fromFields, leafFieldType, normalize) +import Vulkan.Utils.SpirV.Reflect (reflectBytes, reflectFileQ) +import Vulkan.Utils.SpirV.Reflect.OffsetMaps (pushOffsetMap, resourceOffsetMaps) +import Vulkan.Utils.SpirV.Signature (KnownKeyedSigs (..), KnownMaybeSig (..), SigOffsetMap, natT, promoteList, promoteMaybe, promoteOffsetMap) +import Vulkan.Utils.SpirV.Types (LayoutMode (..), classifyType) + +-- | Which pipeline stage a shader is. +data StageKind = VertexStage | FragmentStage | ComputeStage + deriving (Eq, Show) + +{- | A stage's type-level signature: stage, inputs and outputs (location ↦ layout), +resources (@(set, binding)@ ↦ block layout) and an optional push-constant layout. +-} +data ShaderSig + = ShaderSig + StageKind + [(Nat, SigOffsetMap)] + [(Nat, SigOffsetMap)] + [((Nat, Nat), SigOffsetMap)] + (Maybe SigOffsetMap) + +-- Value-level extraction. ------------------------------------------------------- + +{- | The value-level form of a 'ShaderSig', reflected from a 'Module'. This is the +oracle the type level is promoted from, and the source for Vulkan create-infos. +-} +data StageInfo = StageInfo + { stage :: StageKind + , inputs :: [(Word32, OffsetMap)] + , outputs :: [(Word32, OffsetMap)] + , resources :: [((Word32, Word32), OffsetMap)] + , push :: Maybe OffsetMap + } + deriving (Eq, Show) + +-- | Reflect a module's stage signature. +stageInfoOf :: Module -> StageInfo +stageInfoOf m = + StageInfo + { stage = stageKindOf m.shader_stage + , inputs = interfaceOffsetMaps m.input_variables + , outputs = interfaceOffsetMaps m.output_variables + , resources = sortOn fst (resourceOffsetMaps m) + , push = + case V.toList m.push_constants of + (pc : _) -> pushOffsetMap pc + [] -> Nothing + } + +-- | Interface variables as @(location, offset map)@, built-ins dropped, ascending. +interfaceOffsetMaps :: V.Vector InterfaceVariable.InterfaceVariable -> [(Word32, OffsetMap)] +interfaceOffsetMaps vs = + sortOn + fst + -- a non-built-in reads as Nothing (ffi) or the @BuiltIn (-1)@ sentinel (yaml) + [ (v.location, g) + | v <- V.toList vs + , v.built_in `elem` [Nothing, Just (BuiltIn (-1))] + , Just td <- [v.type_description] + , Just g <- [interfaceOffsetMap td] + ] + +-- | The offset map of a single interface variable (a scalar/vector at offset 0). +interfaceOffsetMap :: TypeDescription -> Maybe OffsetMap +interfaceOffsetMap td = do + numeric <- classifyType td + pure (normalize (fromFields Std430Layout Nothing [("v", leafFieldType numeric)])) + +stageKindOf :: Int -> StageKind +stageKindOf n + | n == 0x01 = VertexStage + | n == 0x10 = FragmentStage + | otherwise = ComputeStage + +{- | The interface oracle: every input of the second stage must have an +equal-typed output in the first. (Use as @matchInterface vert frag@.) +-} +matchInterface :: StageInfo -> StageInfo -> Either String () +matchInterface producer consumer = + mapM_ check consumer.inputs + where + outs = producer.outputs + check (loc, want) = + case lookup loc outs of + Just have + | have == want -> Right () + | otherwise -> + Left ("interface mismatch at location " <> show loc) + Nothing -> + Left ("input at location " <> show loc <> " has no matching output") + +{- | A linked vertex+fragment pipeline's combined signature (value-level oracle): +the merged resources (shared @(set, binding)@s deduped) and push constants, the +vertex stage's inputs (vertex attributes) and the fragment stage's outputs +(colour attachments). +-} +data Linked = Linked + { resources :: [((Word32, Word32), OffsetMap)] + , push :: Maybe OffsetMap + , inputs :: [(Word32, OffsetMap)] + , outputs :: [(Word32, OffsetMap)] + } + deriving (Eq, Show) + +{- | Link a vertex and a fragment stage: the interface must match, shared bindings +and push constants must agree, and the resources union. Mirrors the type-level +'MatchInterface' + 'CompatibleResources'. +-} +linkStages :: StageInfo -> StageInfo -> Either String Linked +linkStages vert frag = do + matchInterface vert frag + resources <- mergeAssoc showKey vert.resources frag.resources + push <- mergePush vert.push frag.push + pure + Linked + { resources = sortOn fst resources + , push + , inputs = vert.inputs + , outputs = frag.outputs + } + where + showKey (s, b) = "(set " <> show s <> ", binding " <> show b <> ")" + +-- | Union two keyed offset-map lists; a shared key whose maps differ is an error. +mergeAssoc :: (Eq k) => (k -> String) -> [(k, OffsetMap)] -> [(k, OffsetMap)] -> Either String [(k, OffsetMap)] +mergeAssoc shw xs ys = foldr step (Right xs) ys + where + step (k, g) acc = do + m <- acc + case lookup k m of + Nothing -> Right ((k, g) : m) + Just g' + | g' == g -> Right m + | otherwise -> Left ("incompatible layouts at " <> shw k) + +mergePush :: Maybe OffsetMap -> Maybe OffsetMap -> Either String (Maybe OffsetMap) +mergePush Nothing b = Right b +mergePush a Nothing = Right a +mergePush (Just a) (Just b) + | a == b = Right (Just a) + | otherwise = Left "incompatible push-constant layouts between stages" + +-- Merged pipeline-layout signature. --------------------------------------------- + +{- | A merged pipeline-layout signature at the type level: the descriptor blocks by +@(set, binding)@ and the push-constant block, unified across a family of shaders. +The type-level mirror of 'LayoutInfo'. +-} +data LayoutSig = LayoutSig [((Nat, Nat), SigOffsetMap)] (Maybe SigOffsetMap) + +{- | The value-level merged layout 'reflectPipelineLayoutSig' promotes (its oracle): +each descriptor block's 'OffsetMap' by @(set, binding)@ ascending, and the +push-constant block. +-} +data LayoutInfo = LayoutInfo + { resources :: [((Word32, Word32), OffsetMap)] + , push :: Maybe OffsetMap + } + deriving (Eq, Show) + +{- | Merge several stages into one pipeline-layout signature: descriptor blocks are +unioned (a shared @(set, binding)@ whose layouts disagree is a 'Left') and the +push-constant blocks unified. Unlike 'linkStages' there is no interface check — one +layout is shared across pipelines whose vertex\/fragment interfaces differ. +-} +mergeLayout :: [Module] -> Either String LayoutInfo +mergeLayout modules = do + resources <- foldl' addResources (Right []) infos + push <- foldl' addPush (Right Nothing) infos + pure LayoutInfo{resources = sortOn fst resources, push} + where + infos = map stageInfoOf modules + addResources acc info = acc >>= mergeAssoc showKey info.resources + addPush acc info = acc >>= \p -> mergePush p info.push + showKey (s, b) = "(set " <> show s <> ", binding " <> show b <> ")" + +{- | Reflect a type-level 'LayoutSig' back to its value 'LayoutInfo' — the oracle +view, for validating the promotion and (later) driving bind-site checks. +-} +class KnownLayoutSig (sig :: LayoutSig) where + layoutSigVal :: Proxy sig -> LayoutInfo + +instance (KnownKeyedSigs rs, KnownMaybeSig p) => KnownLayoutSig ('LayoutSig rs p) where + layoutSigVal _ = LayoutInfo{resources = keyedSigsVal (Proxy @rs), push = maybeSigVal (Proxy @p)} + +-- Type-level checks. ------------------------------------------------------------ + +{- | Holds when every input of @f@ has a matching-typed output of @v@ at the same +location (extra outputs of @v@ are allowed). A mismatch is a compile error. +-} +type family MatchInterface (v :: ShaderSig) (f :: ShaderSig) :: Constraint where + MatchInterface ('ShaderSig _ _ vouts _ _) ('ShaderSig _ fins _ _ _) = MatchAll fins vouts + +type family MatchAll (ins :: [(Nat, SigOffsetMap)]) (outs :: [(Nat, SigOffsetMap)]) :: Constraint where + MatchAll '[] _ = () + MatchAll ('(loc, g) ': rest) outs = (MatchOne loc g (Lookup loc outs), MatchAll rest outs) + +type family MatchOne (loc :: Nat) (want :: SigOffsetMap) (have :: Maybe SigOffsetMap) :: Constraint where + MatchOne _ g ('Just g) = () + MatchOne loc want ('Just have) = + TypeError + ( 'Text "Interface mismatch at location " + ':<>: 'ShowType loc + ':<>: 'Text ":" + ':$$: 'Text " vertex out: " + ':<>: 'ShowType have + ':$$: 'Text " fragment in: " + ':<>: 'ShowType want + ) + MatchOne loc _ 'Nothing = + TypeError + ('Text "Fragment input at location " ':<>: 'ShowType loc ':<>: 'Text " has no matching vertex output.") + +type family Lookup (k :: Nat) (xs :: [(Nat, SigOffsetMap)]) :: Maybe SigOffsetMap where + Lookup _ '[] = 'Nothing + Lookup k ('(k, v) ': _) = 'Just v + Lookup k ('(_, _) ': rest) = Lookup k rest + +{- | Holds when every descriptor block and push constant the two stages /share/ +(same @(set, binding)@) has the same layout. Disjoint resources are fine; a +shared binding with differing layouts is a compile error. +-} +type family CompatibleResources (v :: ShaderSig) (f :: ShaderSig) :: Constraint where + CompatibleResources ('ShaderSig _ _ _ vres vpush) ('ShaderSig _ _ _ fres fpush) = + (CompatAll vres fres, CompatPush vpush fpush) + +type family CompatAll (xs :: [((Nat, Nat), SigOffsetMap)]) (ys :: [((Nat, Nat), SigOffsetMap)]) :: Constraint where + CompatAll '[] _ = () + CompatAll ('(k, g) ': rest) ys = (CompatOne k g (LookupR k ys), CompatAll rest ys) + +type family CompatOne (k :: (Nat, Nat)) (g :: SigOffsetMap) (m :: Maybe SigOffsetMap) :: Constraint where + CompatOne _ _ 'Nothing = () + CompatOne _ g ('Just g) = () + CompatOne k _ ('Just _) = + TypeError + ( 'Text "Resource layout mismatch at set/binding " + ':<>: 'ShowType k + ':<>: 'Text " between stages." + ) + +type family CompatPush (a :: Maybe SigOffsetMap) (b :: Maybe SigOffsetMap) :: Constraint where + CompatPush 'Nothing _ = () + CompatPush _ 'Nothing = () + CompatPush ('Just g) ('Just g) = () + CompatPush ('Just _) ('Just _) = + TypeError ('Text "Push-constant layouts differ between stages.") + +type family LookupR (k :: (Nat, Nat)) (xs :: [((Nat, Nat), SigOffsetMap)]) :: Maybe SigOffsetMap where + LookupR _ '[] = 'Nothing + LookupR k ('(k, v) ': _) = 'Just v + LookupR k ('(_, _) ': rest) = LookupR k rest + +-- Generation. ------------------------------------------------------------------- + +-- | Reflect a compiled @.spv@ and emit @type \ = \@. +reflectStageSig :: String -> FilePath -> Q [Dec] +reflectStageSig name path = do + m <- reflectFileQ path + pure [TySynD (mkName name) [] (promoteStageInfo (stageInfoOf m))] + +{- | As 'reflectStageSig', but from SPIR-V bytecode already in hand — e.g. a +quasiquoted shader imported from another module (the Template Haskell stage +restriction applies). +-} +reflectStageSigBytes :: String -> ByteString -> Q [Dec] +reflectStageSigBytes name bytes = do + m <- runIO (reflectBytes bytes) + pure [TySynD (mkName name) [] (promoteStageInfo (stageInfoOf m))] + +promoteStageInfo :: StageInfo -> Type +promoteStageInfo si = + PromotedT 'ShaderSig + `AppT` promoteStage si.stage + `AppT` promoteList (promoteLocated promoteOffsetMap) si.inputs + `AppT` promoteList (promoteLocated promoteOffsetMap) si.outputs + `AppT` promoteList (promoteKeyed promoteOffsetMap) si.resources + `AppT` promoteMaybe promoteOffsetMap si.push + +promoteStage :: StageKind -> Type +promoteStage = \case + VertexStage -> PromotedT 'VertexStage + FragmentStage -> PromotedT 'FragmentStage + ComputeStage -> PromotedT 'ComputeStage + +promoteLocated :: (a -> Type) -> (Word32, a) -> Type +promoteLocated f (loc, x) = pair (natT loc) (f x) + +promoteKeyed :: (a -> Type) -> ((Word32, Word32), a) -> Type +promoteKeyed f ((s, b), x) = pair (pair (natT s) (natT b)) (f x) + +pair :: Type -> Type -> Type +pair a b = PromotedTupleT 2 `AppT` a `AppT` b + +{- | Reflect the @.spv@ of a pipeline's shaders and emit +@type \ = \@ — the descriptor blocks by +@(set, binding)@ and push constants merged across the stages ('mergeLayout' is the +oracle). A layout disagreement between stages fails the splice. The type-level +counterpart of 'Vulkan.Utils.SpirV.Descriptors.mergedDescriptorSetLayoutInfos'. +-} +reflectPipelineLayoutSig :: String -> [FilePath] -> Q [Dec] +reflectPipelineLayoutSig name paths = do + modules <- traverse reflectFileQ paths + case mergeLayout modules of + Left err -> fail ("reflectPipelineLayoutSig: " <> err) + Right info -> pure [TySynD (mkName name) [] (promoteLayoutSig info)] + +-- | As 'reflectPipelineLayoutSig', but from SPIR-V bytecode already in hand. +reflectPipelineLayoutSigBytes :: String -> [ByteString] -> Q [Dec] +reflectPipelineLayoutSigBytes name bytess = do + modules <- runIO (traverse reflectBytes bytess) + case mergeLayout modules of + Left err -> fail ("reflectPipelineLayoutSigBytes: " <> err) + Right info -> pure [TySynD (mkName name) [] (promoteLayoutSig info)] + +promoteLayoutSig :: LayoutInfo -> Type +promoteLayoutSig info = + PromotedT 'LayoutSig + `AppT` promoteList (promoteKeyed promoteOffsetMap) info.resources + `AppT` promoteMaybe promoteOffsetMap info.push diff --git a/src/Vulkan/Utils/SpirV/TH.hs b/src/Vulkan/Utils/SpirV/TH.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/TH.hs @@ -0,0 +1,140 @@ +{-| Template Haskell entry points: reflect a compiled @.spv@ at build time and +splice Haskell record types for its uniform / storage / push-constant blocks. + +Types are keyed by their SPIR-V struct name and generated at most once; a name +that already resolves in scope (e.g. generated from another shader that shares +an include) is referenced rather than redefined, so shared GLSL types map to a +single shared Haskell type. +-} +module Vulkan.Utils.SpirV.TH + ( reflectShaderTypes + , reflectShaderTypesWith + , reflectShaderTypesBytes + , reflectShaderTypesBytesWith + , reflectModuleTypes + , reflectModuleTypesWith + ) where + +import Data.ByteString (ByteString) +import Data.Map.Strict qualified as Map +import Data.Vector qualified as V +import Language.Haskell.TH + +import Data.SpirV.Reflect.BlockVariable qualified +import Data.SpirV.Reflect.DescriptorBinding qualified +import Data.SpirV.Reflect.Enums.DescriptorType qualified as R +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified +import Data.SpirV.Reflect.TypeDescription (TypeDescription) + +import Vulkan.Utils.SpirV.Block (allMembers16, collectStructs, structRecordDec, structTypeName) +import Vulkan.Utils.SpirV.Reflect (reflectBytes, reflectFileQ) +import Vulkan.Utils.SpirV.Types (LayoutMode (..), TypeMap, geomancyTypeMap) + +{- | Reflect a @.spv@ file and generate record types for its blocks, using the +default 'geomancyTypeMap'. +-} +reflectShaderTypes :: FilePath -> Q [Dec] +reflectShaderTypes = reflectShaderTypesWith geomancyTypeMap + +-- | As 'reflectShaderTypes', with a caller-supplied 'TypeMap'. +reflectShaderTypesWith :: TypeMap -> FilePath -> Q [Dec] +reflectShaderTypesWith tymap path = reflectFileQ path >>= reflectModuleTypesWith tymap + +{- | As 'reflectShaderTypes', but reflecting SPIR-V bytecode already in hand +rather than reading a @.spv@ file — e.g. the 'ByteString' a @[comp|…|]@ +quasiquoter produced in a shader module, referenced from the module that +assembles the pipeline: + +@ +reflectShaderTypesBytes Shaders.compSpirv +@ + +No file is involved. Because the bytes are an ordinary imported binding, GHC's +cross-module recompilation reruns the splice when they change, so (unlike the +file path) there is no 'Language.Haskell.TH.Syntax.addDependentFile' to forget. +The usual Template Haskell stage restriction applies: the bytes must come from a +different module than the splice. +-} +reflectShaderTypesBytes :: ByteString -> Q [Dec] +reflectShaderTypesBytes = reflectShaderTypesBytesWith geomancyTypeMap + +-- | As 'reflectShaderTypesBytes', with a caller-supplied 'TypeMap'. +reflectShaderTypesBytesWith :: TypeMap -> ByteString -> Q [Dec] +reflectShaderTypesBytesWith tymap bytes = runIO (reflectBytes bytes) >>= reflectModuleTypesWith tymap + +{- | Generate record types for every block a reflected 'Module' declares. + +The shared core of 'reflectShaderTypes' and 'reflectShaderTypesBytes', exposed so +a caller who already holds a 'Module' can reach codegen without re-reflecting — +and can reflect once, then splice from the same 'Module' in more than one place. +-} +reflectModuleTypes :: Module -> Q [Dec] +reflectModuleTypes = reflectModuleTypesWith geomancyTypeMap + +-- | As 'reflectModuleTypes', with a caller-supplied 'TypeMap'. +reflectModuleTypesWith :: TypeMap -> Module -> Q [Dec] +reflectModuleTypesWith tymap = genStructs tymap . moduleStructCandidates + +{- | The @OpTypeStruct@ descriptions worth turning into records, each paired with +the layout its 'Storable' should follow. Each block is expanded through +'collectStructs' so nested and array-element structs (e.g. an SSBO's @Sphere[]@ +element) are generated too. +-} +moduleStructCandidates :: Module -> [(LayoutMode, TypeDescription)] +moduleStructCandidates m = + concatMap (uncurry collectStructs) $ + [ (layoutForDescriptor b.descriptor_type, td) + | b <- V.toList m.descriptor_bindings + , Just td <- [b.type_description] + ] + ++ [ (Std430Layout, td) + | pc <- V.toList m.push_constants + , Just td <- [pc.type_description] + ] + +layoutForDescriptor :: R.DescriptorType -> LayoutMode +layoutForDescriptor = \case + R.DESCRIPTOR_TYPE_UNIFORM_BUFFER -> Std140Layout + _ -> Std430Layout + +genStructs :: TypeMap -> [(LayoutMode, TypeDescription)] -> Q [Dec] +genStructs tymap = go Map.empty + where + go _ [] = pure [] + go seen ((layout, td) : rest) = + case structTypeName td of + Nothing -> go seen rest + Just nm -> + case Map.lookup nm seen of + -- Already requested in this splice. + Just prev + | prev == layout -> go seen rest -- same layout; reference it + | allMembers16 td -> go seen rest -- std140 == std430; safe to share + | otherwise -> fail (sharingError nm prev layout) + Nothing -> do + existing <- lookupTypeName nm + case existing of + Just _ -> go (Map.insert nm layout seen) rest -- defined elsewhere; reference it + Nothing -> do + mdec <- structRecordDec tymap layout td + decs <- go (Map.insert nm layout seen) rest + pure $ maybe decs (++ decs) mdec + +{- | A struct used under two layouts that aren't byte-compatible (see +'allMembers16') can't be represented by a single Haskell record. +-} +sharingError :: String -> LayoutMode -> LayoutMode -> String +sharingError nm a b = + "vulkan-utils-spirv: struct '" + <> nm + <> "' is used under both " + <> showLayout a + <> " and " + <> showLayout b + <> " layouts but is not layout-compatible: not every member is 16-byte " + <> "aligned. Make each member 16-byte aligned (e.g. use vec4/mat4) so the " + <> "layouts coincide, or keep the struct to a single layout." + where + showLayout Std140Layout = "std140" + showLayout Std430Layout = "std430" diff --git a/src/Vulkan/Utils/SpirV/Types.hs b/src/Vulkan/Utils/SpirV/Types.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/Types.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE NoFieldSelectors #-} + +{-| Classify a reflected block member into a base scalar + shape, and map it to +a Haskell type that carries a 'Graphics.Gl.Block.Block' instance. + +The mapping is pluggable ('TypeMap'). The default is 'geomancyTypeMap', onto +[geomancy](https://hackage.haskell.org/package/geomancy)'s @Vec*@ \/ @IVec*@ \/ +@UVec*@ \/ @Mat4@ (which carry native std140/std430 'Block' instances). +'linearTypeMap' is a worked /example/ of the same recipe for a library whose +types are parametric (it is not usable for codegen yet — see its note). + +A map names its types by /raw qualified name/ against the library's base module +(e.g. @Geomancy.Vec3@) rather than a compile-time @''@ quote, so this package +depends on no vector library. The names resolve at the /splice site/, so a module +that splices these records must @import Geomancy qualified@ — under the base +module's own name, not an @as@ alias — and have a 'Graphics.Gl.Block.Block' +instance in scope for each mapped type. A missing import surfaces as a plain +\"Not in scope: type constructor Geomancy.Vec3\". + +Build a map for any other vector library the same way with 'mkTypeMap' + +'qualType' (+ 'scalarLeaf' for the base components): 'geomancyTypeMap' shows the +monomorphic case (the scalar is baked into the name), 'linearTypeMap' the +parametric case (the scalar is applied as a type argument). +-} +module Vulkan.Utils.SpirV.Types + ( ScalarType (..) + , MemberShape (..) + , NumericType (..) + , classifyType + , isBdaPointer + , arrayDims + , LayoutMode (..) + , scalarWidth + , arrayBaseAlign + , leafAlignment + , structBaseAlign + , TypeMap + , mkTypeMap + , scalarLeaf + , qualType + , geomancyTypeMap + , linearTypeMap + ) where + +import Data.Bits ((.&.)) +import Data.Int (Int32, Int64) +import Data.Vector.Storable qualified as VS +import Data.Word (Word32, Word64) +import Graphics.Gl.Block (roundUp) +import Language.Haskell.TH (Type (AppT, ConT), mkName) + +import Data.SpirV.Reflect.Enums.TypeFlags qualified as TypeFlags +import Data.SpirV.Reflect.Traits qualified as Traits +import Data.SpirV.Reflect.TypeDescription (TypeDescription) +import Data.SpirV.Reflect.TypeDescription qualified as TypeDescription + +{- | The base component type of a block member. + +'STInt64' \/ 'STUInt64' are 64-bit integers (@int64_t@ \/ @uint64_t@, the +@GL_EXT_shader_explicit_arithmetic_types_int64@ scalars): 8-byte slots, like +'STDouble'. 'STAddress' is a 64-bit buffer device address (@buffer_reference@ / +@PhysicalStorageBuffer@ pointer): no GLSL scalar spelling, but one 8-byte slot +like any other scalar. Sub-32-bit scalars (@float16@ \/ @int16@) are out of scope. +-} +data ScalarType = STFloat | STDouble | STInt | STUInt | STInt64 | STUInt64 | STBool | STAddress + deriving (Eq, Ord, Show) + +-- | The shape of a block member. +data MemberShape + = ShScalar + | -- | component count (2..4) + ShVector Int + | -- | columns, rows + ShMatrix Int Int + deriving (Eq, Ord, Show) + +{- | Which gl-block layout a block follows. Uniform buffers use std140; storage +buffers and push constants use std430. +-} +data LayoutMode = Std140Layout | Std430Layout + deriving (Eq, Show) + +-- | The byte width of a scalar component (64-bit scalars are 8, the rest 4). +scalarWidth :: ScalarType -> Int +scalarWidth STDouble = 8 +scalarWidth STInt64 = 8 +scalarWidth STUInt64 = 8 +scalarWidth STAddress = 8 +scalarWidth _ = 4 + +{- | The base alignment of an array or matrix column: std140 rounds the +element\/column alignment up to a multiple of 16, std430 keeps it. +-} +arrayBaseAlign :: LayoutMode -> Int -> Int +arrayBaseAlign Std140Layout a = roundUp a 16 +arrayBaseAlign Std430Layout a = a + +{- | The base alignment of a leaf member (scalar\/vector\/matrix) under the +layout. A matrix aligns as its column vector (rounded up to 16 under std140). +-} +leafAlignment :: LayoutMode -> ScalarType -> MemberShape -> Int +leafAlignment mode s = \case + ShScalar -> w + ShVector 2 -> 2 * w + ShVector _ -> 4 * w + ShMatrix _ r -> arrayBaseAlign mode (if r <= 2 then 2 * w else 4 * w) + where + w = scalarWidth s + +{- | The base alignment of a struct: the largest member alignment (at least 1), +rounded up to 16 under std140. +-} +structBaseAlign :: LayoutMode -> [Int] -> Int +structBaseAlign mode alignments = case mode of + Std140Layout -> roundUp base 16 + Std430Layout -> base + where + base = maximum (1 : alignments) + +{- | A numeric (non-struct) leaf type: a base scalar component, a shape +(scalar\/vector\/matrix), and zero or more array dimensions (outermost first; +empty means not an array). +-} +data NumericType = NumericType + { scalar :: ScalarType + , shape :: MemberShape + , array :: [Word32] + } + deriving (Eq, Ord, Show) + +{- | Classify a reflected struct member (a 'TypeDescription') from its numeric +traits and type flags. +-} +classifyType :: TypeDescription -> Maybe NumericType +classifyType + TypeDescription.TypeDescription + { TypeDescription.type_flags = flags + , TypeDescription.traits = mtraits + } = do + Traits.Numeric + { Traits.scalar = Traits.Scalar{Traits.width = width, Traits.signed = signed} + , Traits.vector = Traits.Vector{Traits.component_count = vecN} + , Traits.matrix = Traits.Matrix{Traits.column_count = cols, Traits.row_count = rows} + } <- + numericOf mtraits + let + shape + | cols > 0 = ShMatrix (fromIntegral cols) (fromIntegral rows) + | vecN > 1 = ShVector (fromIntegral vecN) + | otherwise = ShScalar + wide = width >= 64 + baseScalar + | has TypeFlags.TYPE_FLAG_FLOAT = Just $ if wide then STDouble else STFloat + | has TypeFlags.TYPE_FLAG_INT = Just $ case (signed, wide) of + (True, False) -> STInt + (False, False) -> STUInt + (True, True) -> STInt64 + (False, True) -> STUInt64 + | has TypeFlags.TYPE_FLAG_BOOL = Just STBool + | otherwise = Nothing + scalar <- baseScalar + pure + NumericType + { scalar + , shape + , array = maybe [] dimsOf (arrayOf mtraits) + } + where + has bit = (flags .&. bit) /= TypeFlags.TypeFlagBits 0 + + numericOf t = do + TypeDescription.Traits{TypeDescription.numeric = n} <- t + Just n + + arrayOf t = do + TypeDescription.Traits{TypeDescription.array = a} <- t + Just a + +{- | True when this type is a buffer device address: a @buffer_reference@ \/ +@PhysicalStorageBuffer@ pointer (the @REF@ type flag). Such a member is stored as +an 8-byte address, not its pointee inline. +-} +isBdaPointer :: TypeDescription -> Bool +isBdaPointer td = (td.type_flags .&. TypeFlags.TYPE_FLAG_REF) /= TypeFlags.TypeFlagBits 0 + +{- | The array dimensions of a member (outermost first); @[]@ for a non-array, +@[0]@ for a runtime (unsized) array. +-} +arrayDims :: TypeDescription -> [Word32] +arrayDims td = maybe [] dimsOf (fmap (.array) td.traits) + +dimsOf :: Traits.Array -> [Word32] +dimsOf a + | a.dims_count == 0 = [] + | otherwise = VS.toList a.dims + +{- | A pluggable mapping from a classified member to the Haskell type used for +the generated record field. The returned type must have a +'Graphics.Gl.Block.Block' instance. Returning 'Nothing' rejects the member +(the block record is then not generated). +-} +type TypeMap = NumericType -> Maybe Type + +{- | Assemble a 'TypeMap' from a vector and a matrix spelling — the shared core +of 'geomancyTypeMap' / 'linearTypeMap'. Scalars always map to base types (via +'scalarLeaf'); only the vector/matrix cases differ between libraries. + +This maps an /element/ type only: array dimensions are handled one layer up (in +"Vulkan.Utils.SpirV.Block", which wraps the result in 'Vulkan.Utils.SpirV.Array.Array'), +so a member that still carries array dims here is rejected. +-} +mkTypeMap + :: (ScalarType -> Int -> Maybe Type) + -- ^ vector: component scalar and count (2..4) + -> (ScalarType -> Int -> Int -> Maybe Type) + -- ^ matrix: component scalar, columns, rows + -> TypeMap +mkTypeMap vector matrix NumericType{scalar, shape, array} + | not (null array) = Nothing + | otherwise = case shape of + ShScalar -> scalarLeaf scalar + ShVector n -> vector scalar n + ShMatrix c r -> matrix scalar c r + +{- | The Haskell type for a base scalar component, as a global @''@ quote: 'base' +is always in scope, so a field of this type needs no import at the splice site. +'STAddress' has no scalar spelling — a pointer member is mapped to +'Vulkan.Utils.SpirV.DeviceAddress.DeviceAddress' before it reaches a 'TypeMap'. +-} +scalarLeaf :: ScalarType -> Maybe Type +scalarLeaf = \case + STFloat -> Just (ConT ''Float) + STDouble -> Just (ConT ''Double) + STInt -> Just (ConT ''Int32) + STUInt -> Just (ConT ''Word32) + STInt64 -> Just (ConT ''Int64) + STUInt64 -> Just (ConT ''Word64) + STBool -> Just (ConT ''Bool) + STAddress -> Nothing + +{- | A type referenced by /raw qualified name/ (@Module.Type@), resolved at the +splice site. This is how a default 'TypeMap' names a vector library's types +without this package depending on it: the splice site supplies the import. +-} +qualType :: String -> String -> Type +qualType modName typeName = ConT (mkName (modName <> "." <> typeName)) + +{- | The default mapping, onto [geomancy](https://hackage.haskell.org/package/geomancy)'s +vector/matrix types (which carry native std140/std430 'Block' instances). The +names resolve against geomancy's base module, so the splice site needs only a +single @import Geomancy qualified@. +-} +geomancyTypeMap :: TypeMap +geomancyTypeMap = mkTypeMap vector matrix + where + -- geomancy spells the scalar into the type name: Vec3 / IVec3 / UVec3. + vector STFloat n = geomancy <$> sized "Vec" n + vector STInt n = geomancy <$> sized "IVec" n + vector STUInt n = geomancy <$> sized "UVec" n + vector _ _ = Nothing + matrix STFloat 4 4 = Just (geomancy "Mat4") + matrix _ _ _ = Nothing + geomancy = qualType "Geomancy" + +{- | A worked /example/ of mapping a vector library whose types are /parametric/: +[linear](https://hackage.haskell.org/package/linear)'s @V2@ \/ @V3@ \/ @V4@ \/ +@M44@ take the component scalar as a type argument, so the map applies it +(@V3 Float@, @M44 Float@) instead of spelling it into the name as 'geomancyTypeMap' +does. Names resolve against linear's base module (a single @import Linear qualified@). + +Not usable for record generation yet: neither linear nor gl-block ships a +'Graphics.Gl.Block.Block' instance for @V3 Float@ etc., so a generated record +could not derive its 'Foreign.Storable.Storable'. It stands as the template for +the parametric case until linear gains those instances, at which point it becomes +a real alternative default. +-} +linearTypeMap :: TypeMap +linearTypeMap = mkTypeMap vector matrix + where + -- linear's vectors are parametric (V3 a): apply the component scalar. + vector s n + | s `elem` [STFloat, STInt, STUInt] = AppT . linear <$> sized "V" n <*> scalarLeaf s + | otherwise = Nothing + matrix STFloat 4 4 = AppT (linear "M44") <$> scalarLeaf STFloat + matrix _ _ _ = Nothing + linear = qualType "Linear" + +-- | A library type whose name carries its component count, e.g. @Vec3@ \/ @V4@. +sized :: String -> Int -> Maybe String +sized prefix n + | n >= 2 && n <= 4 = Just (prefix <> show n) + | otherwise = Nothing diff --git a/src/Vulkan/Utils/SpirV/VertexInput.hs b/src/Vulkan/Utils/SpirV/VertexInput.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/SpirV/VertexInput.hs @@ -0,0 +1,91 @@ +{-| Build Vulkan vertex-input descriptions from a reflected vertex shader's input +variables. Built-in inputs (e.g. @gl_VertexIndex@) are skipped; the remaining +inputs are packed tightly into a single binding (binding 0), ordered by +@location@, with per-attribute formats taken directly from reflection (SPIR-V +@Format@ shares Vulkan's numeric values). +-} +module Vulkan.Utils.SpirV.VertexInput + ( vertexInputState + , vertexInputAttributes + , vertexInputBinding + ) where + +import Data.List (sortOn) +import Data.Vector qualified as V +import Data.Word (Word32) +import Vulkan.Core10 qualified as Vk +import Vulkan.Zero (zero) + +import Data.SpirV.Enum (BuiltIn (..)) +import Data.SpirV.Reflect.Enums.Format qualified as R +import Data.SpirV.Reflect.InterfaceVariable qualified as InterfaceVariable +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified +import Data.SpirV.Reflect.Traits qualified as Traits + +{- | The vertex-input state reflected from a vertex module: the single packed +binding plus its attributes ('vertexInputBinding' + 'vertexInputAttributes'). A +module with no vertex inputs — e.g. one pulling geometry from an SSBO via +@gl_VertexIndex@ — yields 'zero' (no bindings, no attributes). +-} +vertexInputState :: Module -> Vk.PipelineVertexInputStateCreateInfo '[] +vertexInputState m = + case vertexInputAttributes m of + [] -> zero + attrs -> + zero + { Vk.vertexBindingDescriptions = V.fromList [vertexInputBinding m] + , Vk.vertexAttributeDescriptions = V.fromList attrs + } + +-- | One attribute per non-built-in input variable, tightly packed into binding 0. +vertexInputAttributes :: Module -> [Vk.VertexInputAttributeDescription] +vertexInputAttributes m = go 0 (inputs m) + where + go _ [] = [] + go off ((loc, fmt, sz) : rest) = + zero + { Vk.location = loc + , Vk.binding = 0 + , Vk.format = fmt + , Vk.offset = off + } + : go (off + sz) rest + +{- | The single binding (binding 0, per-vertex) covering all inputs, with stride +equal to their packed size. +-} +vertexInputBinding :: Module -> Vk.VertexInputBindingDescription +vertexInputBinding m = + zero + { Vk.binding = 0 + , Vk.stride = sum [sz | (_, _, sz) <- inputs m] + , Vk.inputRate = Vk.VERTEX_INPUT_RATE_VERTEX + } + +-- | @(location, format, byte size)@ for each non-built-in input, ordered by location. +inputs :: Module -> [(Word32, Vk.Format, Word32)] +inputs m = + sortOn + (\(loc, _, _) -> loc) + -- a non-built-in reads as Nothing (ffi) or the @BuiltIn (-1)@ sentinel (yaml) + [ (v.location, ivFormat v, ivSize v) + | v <- V.toList m.input_variables + , v.built_in `elem` [Nothing, Just (BuiltIn (-1))] + ] + +-- Vulkan-side field extractions. + +ivFormat :: InterfaceVariable.InterfaceVariable -> Vk.Format +ivFormat InterfaceVariable.InterfaceVariable{InterfaceVariable.format = R.Format n} = + Vk.Format (fromIntegral n) + +ivSize :: InterfaceVariable.InterfaceVariable -> Word32 +ivSize InterfaceVariable.InterfaceVariable{InterfaceVariable.numeric = num} = + components * (width `div` 8) + where + Traits.Numeric + { Traits.scalar = Traits.Scalar{Traits.width = width} + , Traits.vector = Traits.Vector{Traits.component_count = vecN} + } = num + components = max 1 vecN diff --git a/test/Fixtures.hs b/test/Fixtures.hs new file mode 100644 --- /dev/null +++ b/test/Fixtures.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| The test fixture shaders, compiled to SPIR-V at build time by the +vulkan-utils GLSL quasiquoters. + +The reflection splices in "Spec" and "LayoutSpec" consume these bytes; the +Template Haskell stage restriction is why they live in their own module. +-} +module Fixtures + ( juliaComp + , pushComp + , ssboStructComp + , nestedComp + , arrayFieldComp + , array2dComp + , bdaComp + , wideComp + , specComp + , meshVert + , meshFrag + , triVert + ) where + +import Data.ByteString (ByteString) +import Vulkan.Utils.ShaderQQ.GLSL.Glslang (comp, compileShaderQ, frag, glsl, vert) + +{- | A Julia-set compute shader whose @Params@ UBO (set 0, binding 0, std140) +becomes the generated record, next to an @OutputBuffer@ runtime-array SSBO +(binding 1, not generated). Fields are ordered by non-increasing alignment +(vec2\/uvec2 = 8, float\/uint = 4). +-} +juliaComp :: ByteString +juliaComp = + [comp| + #version 450 + + layout(local_size_x = 16, local_size_y = 16) in; + + layout(set = 0, binding = 0, std140) uniform Params { + vec2 center; // align 8 @0 + uvec2 resolution; // align 8 @8 + float escapeRadius; // align 4 @16 + uint maxIterations; // align 4 @20 + } params; + + layout(set = 0, binding = 1, std430) buffer OutputBuffer { + vec4 pixels[]; + }; + + void main() { + uvec2 gid = gl_GlobalInvocationID.xy; + if (gid.x >= params.resolution.x || gid.y >= params.resolution.y) { + return; + } + vec2 z = (vec2(gid) / vec2(params.resolution) * 2.0 - 1.0) * params.escapeRadius; + uint i = 0u; + for (; i < params.maxIterations; ++i) { + z = vec2(z.x * z.x - z.y * z.y, 2.0 * z.x * z.y) + params.center; + if (dot(z, z) > params.escapeRadius * params.escapeRadius) { + break; + } + } + pixels[gid.y * params.resolution.x + gid.x] = + vec4(vec3(float(i) / float(params.maxIterations)), 1.0); + } + |] + +{- | Push-constant reflection: the @Push@ block becomes a Haskell record with a +gl-block std430 Storable, and @pushConstantRanges@ derives the +VkPushConstantRange. Fields are ordered by non-increasing alignment (mat4 = +16, vec2 = 8, float\/int = 4) to satisfy the gl-block layout guardrail. +-} +pushComp :: ByteString +pushComp = + [comp| + #version 450 + + layout(local_size_x = 64) in; + + layout(push_constant, std430) uniform Push { + mat4 transform; + vec2 offset; + float scale; + int count; + } push; + + layout(set = 0, binding = 0, std430) buffer Output { + vec4 data[]; + }; + + void main() { + uint i = gl_GlobalInvocationID.x; + if (i >= uint(push.count)) { + return; + } + data[i] = push.transform * vec4(push.offset * push.scale, 0.0, 1.0); + } + |] + +{- | SSBO arrays of structs: the @Particle@ element type is generated as a +std430 record even though the wrapping @Particles@ block is a runtime array +(not itself representable as a flat record). Fields are ordered by +non-increasing alignment (vec3 = 16, vec2 = 8, float\/uint = 4). +-} +ssboStructComp :: ByteString +ssboStructComp = + [comp| + #version 450 + + layout(local_size_x = 64) in; + + struct Particle { + vec3 position; // align 16 @0 + vec2 velocity; // align 8 @16 + float mass; // align 4 @24 + uint flags; // align 4 @28 + }; + + layout(set = 0, binding = 0, std430) buffer Particles { + Particle items[]; + }; + + void main() { + uint i = gl_GlobalInvocationID.x; + items[i].position += vec3(items[i].velocity, 0.0) * items[i].mass; + } + |] + +{- | Nested structs as fields, plus cross-layout sharing. The @Material@ struct +is all-vec4 (every member 16-byte aligned), so std140 and std430 lay it out +identically: it is used both as a field of the std140 @Scene@ UBO and as the +element of the std430 @Mats@ SSBO, and a single generated record is shared +("promoted") across both. +-} +nestedComp :: ByteString +nestedComp = + [comp| + #version 450 + + layout(local_size_x = 1) in; + + struct Material { + vec4 albedo; + vec4 emission; + }; + + layout(set = 0, binding = 0, std140) uniform Scene { + Material sun; // nested struct field @0 (size 32) + vec4 tint; // @32 + } scene; + + layout(set = 0, binding = 1, std430) buffer Mats { + Material mats[]; + }; + + layout(set = 0, binding = 2, std430) writeonly buffer O { + vec4 o[]; + }; + + void main() { + o[0] = scene.sun.albedo + scene.sun.emission + scene.tint + mats[0].emission; + } + |] + +{- | Fixed-size array fields, mapped to @Array n a@. The same fields appear in a +std140 UBO and a std430 SSBO to show the stride difference: std140 rounds +every element up to 16 bytes, std430 packs tightly. +-} +arrayFieldComp :: ByteString +arrayFieldComp = + [comp| + #version 450 + + layout(local_size_x = 1) in; + + layout(set = 0, binding = 0, std140) uniform Kernel140 { + vec4 taps[4]; // stride 16 in both + float weights[4]; // stride 16 in std140 + } k140; + + layout(set = 0, binding = 1, std430) buffer Kernel430 { + vec4 taps[4]; // stride 16 + float weights[4]; // stride 4 in std430 + } k430; + + layout(set = 0, binding = 2, std430) writeonly buffer O { + vec4 o[]; + }; + + void main() { + o[0] = k140.taps[0] * k140.weights[0] + k430.taps[0] * k430.weights[0]; + } + |] + +{- | A multi-dimensional array field: @float grid[3][4]@ maps to +@Array 3 (Array 4 Float)@. In std430 the inner stride is 4 (outer 16); in +std140 the inner stride is 16 (outer 64). +-} +array2dComp :: ByteString +array2dComp = + [comp| + #version 450 + + layout(local_size_x = 1) in; + + layout(set = 0, binding = 0, std430) buffer Grid430 { + vec4 head; // @0 + float grid[3][4]; // @16, inner stride 4, outer stride 16 + } g430; + + layout(set = 0, binding = 1, std140) uniform Grid140 { + vec4 head; // @0 + float grid[3][4]; // @16, inner stride 16, outer stride 64 + } g140; + + layout(set = 0, binding = 2, std430) writeonly buffer O { + vec4 o[]; + }; + + void main() { + o[0] = g430.head + g140.head + vec4(g430.grid[0][0] + g140.grid[0][0]); + } + |] + +{- | A self-referential buffer_reference (BDA) type: a BVH-ish node whose +children are 64-bit device addresses back to @Node@. Reflection-driven codegen +maps the pointer members to @DeviceAddress Node@ (8-byte address), not an +inlined struct, and generates @Node@ once despite the cycle. + +buffer_reference needs SPIR-V 1.3+, hence the vulkan1.2 target. +-} +bdaComp :: ByteString +bdaComp = + $( compileShaderQ + (Just "vulkan1.2") + "comp" + Nothing + [glsl| + #version 460 + #extension GL_EXT_buffer_reference : require + + layout(local_size_x = 64) in; + + layout(buffer_reference) buffer Node; // fwd decl enables self-reference + layout(buffer_reference, std430) buffer Node { + vec4 boundsMin; + vec4 boundsMax; + Node left; // BDA pointer -> cycle + Node right; // BDA pointer -> cycle + uint primCount; + }; + + layout(push_constant, std430) uniform Bvh { + Node root; // entry address into the graph + } bvh; + + layout(set = 0, binding = 0, std430) writeonly buffer Out { + uint hits[]; + }; + + void main() { + Node n = bvh.root; + uint count = 0u; + for (int i = 0; i < 8; ++i) { + count += n.primCount; + n = n.left; + } + hits[gl_GlobalInvocationID.x] = count; + } + |] + ) + +{- | 64-bit integer block members. A uint64_t\/int64_t occupies an 8-byte std430 +slot (alignment 8), exactly like a double — the regression fixture for +scalar-width-faithful classification, so a 64-bit int is never laid out as a +4-byte int. Fields are ordered by non-increasing alignment (8, 8, 4) to keep +gl-block's Generic layout valid. + +int64 needs the Int64 capability, hence the vulkan1.1 target. +-} +wideComp :: ByteString +wideComp = + $( compileShaderQ + (Just "vulkan1.1") + "comp" + Nothing + [glsl| + #version 460 + #extension GL_EXT_shader_explicit_arithmetic_types_int64 : require + + layout(local_size_x = 1) in; + + layout(push_constant, std430) uniform Wide { + uint64_t hi; // align 8 @0, size 8 + int64_t lo; // align 8 @8, size 8 + uint tag; // align 4 @16, size 4 + } wide; + + layout(set = 0, binding = 0, std430) writeonly buffer Out { + uint sink[]; + }; + + void main() { + sink[0] = uint(wide.hi) + uint(wide.lo) + wide.tag; + } + |] + ) + +{- | Specialization-constant reflection. The ids are deliberately non-contiguous +(0 and 3) to show that map entries follow the shader's actual constant_ids +while values pack tightly (offsets 0, 4). +-} +specComp :: ByteString +specComp = + [comp| + #version 450 + + layout(local_size_x = 64) in; + + layout(constant_id = 0) const uint count = 1u; + layout(constant_id = 3) const float scale = 1.0; + + layout(set = 0, binding = 0, std430) buffer Output { + float xs[]; + }; + + void main() { + uint i = gl_GlobalInvocationID.x; + if (i < count) { + xs[i] = scale; + } + } + |] + +{- | Vertex stage for the type-verified pipeline-assembly tests. Shares the +@Scene@ UBO (set 0, binding 0) with 'meshFrag' (vertex uses viewProj; fragment +uses the light fields), carries a vertex-only @Model@ push constant, and feeds +the fragment stage @outNormal@ (loc 0) + @outUV@ (loc 1). +-} +meshVert :: ByteString +meshVert = + [vert| + #version 450 + + layout(location = 0) in vec3 inPosition; + layout(location = 1) in vec3 inNormal; + layout(location = 2) in vec2 inUV; + + layout(set = 0, binding = 0, std140) uniform Scene { + mat4 viewProj; + vec4 lightDir; + vec4 lightColor; + } scene; + + layout(push_constant, std430) uniform Model { + mat4 model; + } model; + + layout(location = 0) out vec3 outNormal; + layout(location = 1) out vec2 outUV; + + void main() { + gl_Position = scene.viewProj * model.model * vec4(inPosition, 1.0); + outNormal = mat3(model.model) * inNormal; + outUV = inUV; + } + |] + +{- | Fragment stage paired with 'meshVert'. Consumes the vertex outputs +(inNormal loc 0, inUV loc 1), shares the @Scene@ UBO (set 0, binding 0 — using +the light fields the vertex stage ignores), and reads a fragment-only +@Materials@ SSBO (set 0, binding 1). +-} +meshFrag :: ByteString +meshFrag = + [frag| + #version 450 + + layout(location = 0) in vec3 inNormal; + layout(location = 1) in vec2 inUV; + + layout(set = 0, binding = 0, std140) uniform Scene { + mat4 viewProj; + vec4 lightDir; + vec4 lightColor; + } scene; + + struct Material { + vec4 albedo; + vec4 params; + }; + + layout(set = 0, binding = 1, std430) buffer Materials { + Material materials[]; + }; + + layout(location = 0) out vec4 outColor; + + void main() { + float ndl = max(dot(normalize(inNormal), normalize(scene.lightDir.xyz)), 0.0); + vec4 albedo = materials[0].albedo * vec4(inUV, 1.0, 1.0); + outColor = albedo * scene.lightColor * ndl; + } + |] + +{- | Vertex-input reflection: three attributes (vec3 \/ vec2 \/ vec4 at +locations 0\/1\/2) that pack tightly to offsets 0\/12\/20 and a 36-byte binding +stride. +-} +triVert :: ByteString +triVert = + [vert| + #version 450 + + layout(location = 0) in vec3 inPosition; + layout(location = 1) in vec2 inUV; + layout(location = 2) in vec4 inColor; + + layout(location = 0) out vec2 outUV; + layout(location = 1) out vec4 outColor; + + void main() { + gl_Position = vec4(inPosition, 1.0); + outUV = inUV; + outColor = inColor; + } + |] diff --git a/test/LayoutSpec.hs b/test/LayoutSpec.hs new file mode 100644 --- /dev/null +++ b/test/LayoutSpec.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| Tests for the structured 'Layout' IR, its normalization to a scalar 'OffsetMap', +and the value-level unifier. +-} +module LayoutSpec (tests) where + +import Data.Either (isLeft) +import Data.List (isInfixOf) +import Data.Map.Strict qualified as Map +import Data.Text (unpack) +import Data.Vector qualified as V +import Test.Tasty +import Test.Tasty.HUnit + +import Data.SpirV.Reflect.BlockVariable qualified +import Data.SpirV.Reflect.DescriptorBinding qualified +import Data.SpirV.Reflect.FFI (loadBytes) +import Data.SpirV.Reflect.Module (Module) +import Data.SpirV.Reflect.Module qualified +import Data.SpirV.Reflect.TypeDescription (TypeDescription) + +import Vulkan.Utils.SpirV.Layout +import Vulkan.Utils.SpirV.Layout qualified as OffsetMap (OffsetMap (..)) +import Vulkan.Utils.SpirV.Types (LayoutMode (..), ScalarType (..)) + +import Fixtures qualified + +tests :: TestTree +tests = + testGroup + "layout IR + unification" + [ structuredTests + , normalizeTests + , unifyTests + , runtimeTests + , mergeTests + , reflectionTests + ] + +-- Convenience constructors. ----------------------------------------------------- + +-- | A single-member std430 layout. +field430 :: FieldType -> Layout +field430 ft = fromFields Std430Layout Nothing [("x", ft)] + +-- | A single-member std140 layout. +field140 :: FieldType -> Layout +field140 ft = fromFields Std140Layout Nothing [("x", ft)] + +structuredTests :: TestTree +structuredTests = + testGroup + "structured layout (fromFields)" + [ testCase "std430 packs by member alignment" $ do + -- mat4 (align 16) @0 size 64, vec2 (align 8) @64, float @72, int @76 + let l = + fromFields + Std430Layout + (Just "Push") + [ ("transform", Matrix STFloat 4 4) + , ("offset", Vector STFloat 2) + , ("scale", Scalar STFloat) + , ("count", Scalar STInt) + ] + offsets l @?= [("transform", 0), ("offset", 64), ("scale", 72), ("count", 76)] + l.size @?= Just 80 + l.align @?= 16 + , testCase "std140 rounds a scalar array's stride and the struct align to 16" $ do + let l = field140 (ArrayOf (Sized 4) (Scalar STFloat)) + l.align @?= 16 + l.size @?= Just 64 -- stride 16 * 4 + , testCase "std430 packs a scalar array tightly" $ do + let l = field430 (ArrayOf (Sized 4) (Scalar STFloat)) + l.align @?= 4 + l.size @?= Just 16 + , testCase "vec3 occupies 12 bytes but aligns to 16" $ do + let l = fromFields Std430Layout Nothing [("a", Vector STFloat 3), ("b", Scalar STFloat)] + offsets l @?= [("a", 0), ("b", 12)] + ] + +normalizeTests :: TestTree +normalizeTests = + testGroup + "normalize to scalar offset map" + [ testCase "vec4 flattens to four floats" $ + (normalize (field430 (Vector STFloat 4))).slots + @?= [Slot 0 STFloat, Slot 4 STFloat, Slot 8 STFloat, Slot 12 STFloat] + , testCase "mat4 flattens column-major to a 16-float offset map" $ + map (.offset) (normalize (field430 (Matrix STFloat 4 4))).slots + @?= [0, 4, 8, 12, 16, 20, 24, 28, 32, 36, 40, 44, 48, 52, 56, 60] + , testCase "std140 float[4] strides by 16" $ + map (.offset) (normalize (field140 (ArrayOf (Sized 4) (Scalar STFloat)))).slots + @?= [0, 16, 32, 48] + ] + +unifyTests :: TestTree +unifyTests = + testGroup + "unify (layout equivalence)" + [ testCase "mat4 == vec4[4] == float[16] under std430" $ do + let + m = normalize (field430 (Matrix STFloat 4 4)) + v = normalize (field430 (ArrayOf (Sized 4) (Vector STFloat 4))) + f = normalize (field430 (ArrayOf (Sized 16) (Scalar STFloat))) + foldUnify m [v, f] @?= Right m + , testCase "float[16] under std140 is NOT layout-equivalent to mat4" $ do + let + m = normalize (field430 (Matrix STFloat 4 4)) + f = normalize (field140 (ArrayOf (Sized 16) (Scalar STFloat))) + case unify m f of + Left (SlotMismatch off _ _) -> off @?= 4 -- first divergence: mat4 has a float here + other -> assertFailure ("expected a SlotMismatch at 4, got " <> show other) + , testCase "a scalar-kind mismatch is reported with its offset" $ do + let + a = normalize (field430 (Vector STFloat 2)) + b = normalize (field430 (Vector STInt 2)) + unify a b @?= Left (SlotMismatch 0 STFloat STInt) + , testCase "differing total size fails even when slots agree" $ do + -- Same scalar slots, different declared size (e.g. extra trailing padding). + let + a = normalize (field430 (Vector STFloat 4)) + big = a{OffsetMap.size = Just 32} + unify a big @?= Left (SizeMismatch 16 32) + , testCase "renderMismatch is legible" $ + assertBool "mentions offset and types" $ + "offset 4" `isInfixOf` renderMismatch (SlotMismatch 4 STFloat STInt) + && "float" `isInfixOf` renderMismatch (SlotMismatch 4 STFloat STInt) + ] + +runtimeTests :: TestTree +runtimeTests = + testGroup + "runtime arrays (unification with a hole)" + [ testCase "an open vec4[] offset map is open (no size, has a tail)" $ do + let g = normalize (field430 (ArrayOf Runtime (Vector STFloat 4))) + g.size @?= Nothing + fmap (.stride) g.tail @?= Just 16 + , testCase "a runtime vec4[] unifies with a concrete vec4[3], pinning the length" $ do + let + open = normalize (field430 (ArrayOf Runtime (Vector STFloat 4))) + closed = normalize (field430 (ArrayOf (Sized 3) (Vector STFloat 4))) + unify open closed @?= Right closed + unify closed open @?= Right closed -- symmetric + , testCase "a runtime vec4[] rejects an offset map that is not whole elements" $ do + let + open = normalize (field430 (ArrayOf Runtime (Vector STFloat 4))) + ragged = normalize (field430 (ArrayOf (Sized 5) (Scalar STFloat))) + assertBool "should not unify" (isLeft (unify open ragged)) + ] + +mergeTests :: TestTree +mergeTests = + testGroup + "mergeKeyed (row unification across pipelines)" + [ testCase "disjoint keys union; shared keys must agree" $ do + let + camera = normalize (field140 (Vector STFloat 4)) + lights = normalize (field430 (ArrayOf (Sized 2) (Vector STFloat 4))) + merged = + mergeKeyed + [ ((0, 0) :: (Int, Int), camera) -- vertex stage: set 0 binding 0 + , ((0, 1), lights) -- vertex stage: set 0 binding 1 + , ((0, 0), camera) -- fragment stage: same UBO, must agree + ] + fmap Map.keys merged @?= Right [(0, 0), (0, 1)] + , testCase "a conflicting shared key reports the key and the mismatch" $ do + let + a = normalize (field430 (Vector STFloat 4)) + b = normalize (field430 (Vector STInt 4)) + case mergeKeyed [((0, 0) :: (Int, Int), a), ((0, 0), b)] of + Left (k, SlotMismatch{}) -> k @?= (0, 0) + other -> assertFailure ("expected a keyed SlotMismatch, got " <> show other) + ] + +reflectionTests :: TestTree +reflectionTests = + testGroup + "built from reflected SPIR-V" + [ testCase "push.comp Push has std430 offsets 0/64/72/76, size 80" $ do + m <- loadBytes Fixtures.pushComp + td <- maybe (assertFailure "no push constant block") pure (pushBlock m) + l <- either (assertFailure . ("layoutOf: " <>)) pure (layoutOf Std430Layout td) + map snd (offsets l) @?= [0, 64, 72, 76] + l.size @?= Just 80 + , testCase "push.comp Output (vec4 data[]) is an open offset map with stride 16" $ do + m <- loadBytes Fixtures.pushComp + td <- maybe (assertFailure "no SSBO binding") pure (firstBinding m) + g <- either (assertFailure . ("offsetMapOf: " <>)) pure (offsetMapOf Std430Layout td) + g.size @?= Nothing + fmap (.stride) g.tail @?= Just 16 + , testCase "ssbo-struct Particle[] tail unifies with a concrete Particle[2]" $ do + m <- loadBytes Fixtures.ssboStructComp + td <- maybe (assertFailure "no SSBO binding") pure (firstBinding m) + open <- either (assertFailure . ("offsetMapOf: " <>)) pure (offsetMapOf Std430Layout td) + -- Particle = vec3 @0, vec2 @16, float @24, uint @28 (stride 32). + let + particle = + Struct + ( fromFields + Std430Layout + (Just "Particle") + [ ("position", Vector STFloat 3) + , ("velocity", Vector STFloat 2) + , ("mass", Scalar STFloat) + , ("flags", Scalar STUInt) + ] + ) + closed = normalize (fromFields Std430Layout Nothing [("items", ArrayOf (Sized 2) particle)]) + open `unifies` closed + ] + +-- Helpers. ---------------------------------------------------------------------- + +offsets :: Layout -> [(String, Int)] +offsets l = [(unpack m.name, m.offset) | m <- l.members] + +unifies :: OffsetMap -> OffsetMap -> Assertion +unifies a b = case unify a b of + Right _ -> pure () + Left e -> assertFailure (renderMismatch e) + +pushBlock :: Module -> Maybe TypeDescription +pushBlock m = case V.toList m.push_constants of + (pc : _) -> pc.type_description + [] -> Nothing + +firstBinding :: Module -> Maybe TypeDescription +firstBinding m = case V.toList m.descriptor_bindings of + (b : _) -> b.type_description + [] -> Nothing diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,697 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Main (main) where + +import Data.Bits ((.|.)) +import Data.Either (isLeft) +import Data.Int (Int32, Int64) +import Data.List (sortOn) +import Data.Maybe (isJust) +import Data.Proxy (Proxy (..)) +import Data.Vector qualified as V +import Data.Vector.Storable qualified as VS +import Data.Word (Word32, Word64) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Utils (fillBytes) +import Foreign.Ptr (castPtr) +import Foreign.Storable (Storable (..)) +import GHC.Generics (Generic) +import Geomancy qualified +import Geomancy.Mat4 (identity) +import Geomancy.UVec2 (uvec2) +import Geomancy.Vec2 (Vec2, vec2) +import Geomancy.Vec3 (vec3) +import Geomancy.Vec4 (Vec4, vec4) +import Graphics.Gl.Block (Block, Std140 (..), Std430 (..)) +import Language.Haskell.TH (Type (AppT, ConT), mkName) +import Test.Tasty +import Test.Tasty.HUnit + +import Vulkan.Core10 qualified as Vk + +import Data.SpirV.Reflect.FFI (loadBytes) +import Vulkan.Utils.SpirV.Array qualified as Array +import Vulkan.Utils.SpirV.Buffer (allocArrayBuffer, newBuffer, readBuffer, readBufferElem, writeBufferElem) +import Vulkan.Utils.SpirV.Descriptors (descriptorSetLayoutInfos, mergedDescriptorSetLayoutInfos, mergedPushConstantRanges, pushConstantRanges) +import Vulkan.Utils.SpirV.DeviceAddress (DeviceAddress (..)) +import Vulkan.Utils.SpirV.Layout (ArraySize (..), FieldType (..), fromFields, normalize) +import Vulkan.Utils.SpirV.Layout qualified +import Vulkan.Utils.SpirV.Signature (ArrayOf, Fits, Sig, knownLayoutInstance, layoutSig) +import Vulkan.Utils.SpirV.Specialization (specializationConstants, specializationMapEntries) +import Vulkan.Utils.SpirV.Stage (CompatibleResources, KnownLayoutSig (..), MatchInterface, linkStages, matchInterface, mergeLayout, reflectPipelineLayoutSigBytes, reflectStageSigBytes, stageInfoOf) +import Vulkan.Utils.SpirV.Stage qualified +import Vulkan.Utils.SpirV.Stage qualified as StageInfo (StageInfo (..)) +import Vulkan.Utils.SpirV.TH (reflectShaderTypesBytes) +import Vulkan.Utils.SpirV.Types (LayoutMode (..), MemberShape (..), NumericType (..), ScalarType (..), geomancyTypeMap, linearTypeMap) +import Vulkan.Utils.SpirV.VertexInput (vertexInputAttributes, vertexInputBinding, vertexInputState) + +import Fixtures qualified +import LayoutSpec qualified + +-- Generate the @Params@ record from the quasiquoted compute fixture. +reflectShaderTypesBytes Fixtures.juliaComp + +-- Generate the @Push@ push-constant record (std430) from its fixture. +reflectShaderTypesBytes Fixtures.pushComp + +-- Generate the @Particle@ element record of an SSBO array of structs. The +-- wrapping @Particles@ runtime-array block is (correctly) not generated. +reflectShaderTypesBytes Fixtures.ssboStructComp + +-- Generate @Material@ (shared across a std140 UBO field and a std430 SSBO array, +-- safe because all members are 16-byte aligned) and @Scene@, which has the +-- nested @Material@ as a field. +reflectShaderTypesBytes Fixtures.nestedComp + +-- Generate @Kernel140@ / @Kernel430@: records with fixed-size @Array n a@ fields +-- under std140 (element stride 16) and std430 (tight) layouts. +reflectShaderTypesBytes Fixtures.arrayFieldComp + +-- Generate @Grid430@ / @Grid140@: a 2D array field @float grid[3][4]@ maps to +-- @Array 3 (Array 4 Float)@. +reflectShaderTypesBytes Fixtures.array2dComp + +-- Generate @Node@ (a self-referential @buffer_reference@ struct) and @Bvh@ (a +-- push-constant block holding a @Node@ device address). The pointer members map +-- to @DeviceAddress Node@; @Node@ is generated once despite the cycle. +reflectShaderTypesBytes Fixtures.bdaComp + +-- Generate @Wide@: a std430 push-constant block with 64-bit integer members +-- (@uint64_t hi@ / @int64_t lo@), which must occupy 8-byte slots like a double. +reflectShaderTypesBytes Fixtures.wideComp + +-- A std430 element whose array stride (32) exceeds its packed size (20): vec4 @0 +-- + float @16 -> size 20, rounded up to its 16-byte alignment for the stride. +data Pad = Pad Vec4 Float + deriving stock (Generic, Eq, Show) + deriving anyclass (Block) + deriving (Storable) via (Std430 Pad) + +-- Three types that are layout-equivalent under std430 (same scalar offset map): mat4, vec4[4] and +-- float[16]. Their layout signatures are produced from the value-level normal +-- form (the oracle), so they promote to the SAME 'Sig' and 'Fits' accepts them. +data EquivMat4 +data EquivVec4x4 +data EquivFloat16 + +pure + ( knownLayoutInstance + ''EquivMat4 + (normalize (fromFields Std430Layout Nothing [("m", Matrix STFloat 4 4)])) + ) +pure + ( knownLayoutInstance + ''EquivVec4x4 + (normalize (fromFields Std430Layout Nothing [("a", ArrayOf (Sized 4) (Vector STFloat 4))])) + ) +pure + ( knownLayoutInstance + ''EquivFloat16 + (normalize (fromFields Std430Layout Nothing [("a", ArrayOf (Sized 16) (Scalar STFloat))])) + ) + +-- Compile-time witnesses: each body only type-checks if the 'Fits' constraint +-- holds (a mismatch is a compile error). Returned as 'Bool' so a test can run. +mat4FitsVec4x4 :: (Fits (Sig EquivMat4) (Sig EquivVec4x4)) => Bool +mat4FitsVec4x4 = True + +vec4x4FitsFloat16 :: (Fits (Sig EquivVec4x4) (Sig EquivFloat16)) => Bool +vec4x4FitsFloat16 = True + +pushFitsItself :: (Fits (Sig Push) (Sig Push)) => Bool +pushFitsItself = True + +-- Two records that are layout-equivalent under std430: two vec4s vs four vec2s both flatten to +-- eight floats at offsets 0,4,..,28 (size 32). Real 'Storable' records, so a +-- value written as one can be read back through the other. +data PairA = PairA Vec4 Vec4 + deriving stock (Generic, Eq, Show) + deriving anyclass (Block) + deriving (Storable) via (Std430 PairA) + +data PairB = PairB Vec2 Vec2 Vec2 Vec2 + deriving stock (Generic, Eq, Show) + deriving anyclass (Block) + deriving (Storable) via (Std430 PairB) + +pure + ( knownLayoutInstance + ''PairA + (normalize (fromFields Std430Layout Nothing [("a", Vector STFloat 4), ("b", Vector STFloat 4)])) + ) +pure + ( knownLayoutInstance + ''PairB + ( normalize + ( fromFields + Std430Layout + Nothing + [("a", Vector STFloat 2), ("b", Vector STFloat 2), ("c", Vector STFloat 2), ("d", Vector STFloat 2)] + ) + ) + ) + +-- Stage signatures for a matched vertex+fragment pair (shared Scene UBO, vertex +-- push constant, fragment SSBO). Phase 1 exercises only the interface. +reflectStageSigBytes "MeshVert" Fixtures.meshVert +reflectStageSigBytes "MeshFrag" Fixtures.meshFrag + +-- The merged pipeline-layout signature of the same pair, promoted to the type level. +reflectPipelineLayoutSigBytes "MeshLayout" [Fixtures.meshVert, Fixtures.meshFrag] + +-- Compile-time witness: only type-checks if the vertex→fragment interface matches. +meshInterfaceOk :: (MatchInterface MeshVert MeshFrag) => Bool +meshInterfaceOk = True + +-- Compile-time witness: only type-checks if the shared resources are compatible +-- (the Scene UBO is declared identically in both stages). +meshResourcesOk :: (CompatibleResources MeshVert MeshFrag) => Bool +meshResourcesOk = True + +main :: IO () +main = + defaultMain $ + testGroup + "vulkan-utils-spirv" + [ testGroup + "block record (std140)" + [ testCase "alignment is std140 vec4 (16)" $ + alignment params @?= 16 + , testCase "fields land at the shader's std140 offsets" $ do + -- shader.comp: center@0, resolution@8, escapeRadius@16, maxIterations@20 + let n = sizeOf params + (resX, esc, maxIt) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) params + (,,) + <$> (peekByteOff ptr 8 :: IO Word32) + <*> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 20 :: IO Int32) + resX @?= 512 + esc @?= 2.0 + maxIt @?= 1000 + , testCase "round-trips through Storable" $ do + let n = sizeOf params + rt <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) params + peek (castPtr ptr) + rt @?= params + ] + , testGroup + "field type spelling (TypeMap)" + -- geomancyTypeMap is also exercised end-to-end by the record fixtures. + -- linearTypeMap is a worked example of the parametric case with no Block + -- instances to splice against yet, so these pure checks pin its spelling. + [ testCase "geomancy: scalar in name, single qualifier" $ do + geomancyTypeMap (NumericType STFloat (ShVector 3) []) @?= Just (ConT (mkName "Geomancy.Vec3")) + geomancyTypeMap (NumericType STUInt (ShVector 2) []) @?= Just (ConT (mkName "Geomancy.UVec2")) + geomancyTypeMap (NumericType STFloat (ShMatrix 4 4) []) @?= Just (ConT (mkName "Geomancy.Mat4")) + , testCase "linear: parametric, scalar applied" $ do + linearTypeMap (NumericType STFloat (ShVector 3) []) @?= Just (AppT (ConT (mkName "Linear.V3")) (ConT ''Float)) + linearTypeMap (NumericType STUInt (ShVector 2) []) @?= Just (AppT (ConT (mkName "Linear.V2")) (ConT ''Word32)) + linearTypeMap (NumericType STFloat (ShMatrix 4 4) []) @?= Just (AppT (ConT (mkName "Linear.M44")) (ConT ''Float)) + , testCase "both reject array members and address scalars" $ do + geomancyTypeMap (NumericType STFloat (ShVector 3) [4]) @?= Nothing + linearTypeMap (NumericType STAddress ShScalar []) @?= Nothing + ] + , testGroup + "push-constant block (std430)" + [ testCase "alignment is mat4 (16)" $ + alignment pushc @?= 16 + , testCase "fields land at the shader's std430 offsets" $ do + -- push.comp: transform@0, offset@64, scale@72, count@76 + let n = sizeOf pushc + (sc, cnt) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) pushc + (,) + <$> (peekByteOff ptr 72 :: IO Float) + <*> (peekByteOff ptr 76 :: IO Int32) + sc @?= 2.5 + cnt @?= 7 + , testCase "size covers the last member (80)" $ + sizeOf pushc @?= 80 + , testCase "round-trips through Storable" $ do + -- @Push@ has a @Mat4@ field (no @Eq@), so compare the comparable + -- fields after a Storable round-trip rather than the whole record. + let n = sizeOf pushc + rt <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) pushc + peek (castPtr ptr) :: IO Push + (rt.offset, rt.scale, rt.count) @?= (pushc.offset, pushc.scale, pushc.count) + ] + , testCase "push-constant range from reflection" $ do + m <- loadBytes Fixtures.pushComp + case pushConstantRanges m of + [r] -> do + r.offset @?= 0 + r.size @?= 80 + r.stageFlags @?= Vk.SHADER_STAGE_COMPUTE_BIT + other -> assertFailure ("expected one range, got " <> show (length other)) + , testGroup + "64-bit integer scalars (std430)" + [ testCase "uint64_t/int64_t members land at 8-byte-aligned offsets" $ do + -- wide.comp: hi@0, lo@8, tag@16. A 64-bit int is an 8-byte slot, so + -- tag sits at 16 — under the old 32-bit assumption it would be at 8. + let n = sizeOf wide + (hi, lo, tag) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) wide + (,,) + <$> (peekByteOff ptr 0 :: IO Word64) + <*> (peekByteOff ptr 8 :: IO Int64) + <*> (peekByteOff ptr 16 :: IO Word32) + (hi, lo, tag) @?= (0xDEADBEEFCAFEF00D, -42, 7) + , testCase "record rounds up to its 8-byte alignment (24)" $ + -- gl-block pads the record to a multiple of its base alignment (8); + -- the SPIR-V block extent below is the unpadded 20. + sizeOf wide @?= 24 + , testCase "push-constant range from reflection ends at 20" $ do + -- 16 + 4: tag (a uint) ends at 20, so each int64 before it took 8 + -- bytes — a 4-byte misclassification would put the end at 12. + m <- loadBytes Fixtures.wideComp + case pushConstantRanges m of + [r] -> (r.offset, r.size) @?= (0, 20) + other -> assertFailure ("expected one range, got " <> show (length other)) + , testCase "Wide's std430 Sig has 8-byte int slots at 0/8, uint at 16" $ + layoutSig @Wide + @?= normalize + ( fromFields + Std430Layout + Nothing + [ ("hi", Scalar STUInt64) + , ("lo", Scalar STInt64) + , ("tag", Scalar STUInt) + ] + ) + ] + , testGroup + "buffer_reference (BDA)" + [ testCase "Node's std430 Sig has DeviceAddress slots at 32/40, size 64" $ + -- boundsMin@0, boundsMax@16, left@32, right@40, primCount@48; size 64. + layoutSig @Node + @?= normalize + ( fromFields + Std430Layout + Nothing + [ ("boundsMin", Vector STFloat 4) + , ("boundsMax", Vector STFloat 4) + , ("left", Scalar STAddress) + , ("right", Scalar STAddress) + , ("primCount", Scalar STUInt) + ] + ) + , testCase "DeviceAddress fields land at std430 byte offsets 32 and 40" $ do + let n = Node (vec4 0 0 0 0) (vec4 0 0 0 0) (DeviceAddress 0xCAFE) (DeviceAddress 0xBEEF) 0 + (a32, a40) <- allocaBytes (sizeOf (Std430 n)) $ \p -> do + poke (castPtr p) (Std430 n) + (,) <$> (peekByteOff p 32 :: IO Word64) <*> (peekByteOff p 40 :: IO Word64) + (a32, a40) @?= (0xCAFE, 0xBEEF) + , testCase "push-constant block is a single 8-byte device address" $ do + m <- loadBytes Fixtures.bdaComp + case pushConstantRanges m of + [r] -> (r.offset, r.size) @?= (0, 8) + other -> assertFailure ("expected one range, got " <> show (length other)) + ] + , testGroup + "SSBO array-of-struct element (std430)" + [ testCase "element record alignment is vec3 (16)" $ + alignment particle @?= 16 + , testCase "fields land at the shader's std430 offsets" $ do + -- ssbo-struct.comp: position@0, velocity@16, mass@24, flags@28 + let n = sizeOf particle + (vx, m, fl) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) particle + (,,) + <$> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 24 :: IO Float) + <*> (peekByteOff ptr 28 :: IO Word32) + vx @?= 3.0 + m @?= 1.5 + fl @?= 7 + , testCase "element size is std430-padded (32)" $ + sizeOf particle @?= 32 + ] + , testGroup + "nested struct as a field (shared across layouts)" + [ testCase "nested element record offsets (Material)" $ do + let n = sizeOf mat + (al, em) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) mat + (,) <$> (peekByteOff ptr 0 :: IO Float) <*> (peekByteOff ptr 16 :: IO Float) + alignment mat @?= 16 + sizeOf mat @?= 32 + al @?= 1.0 + em @?= 2.0 + , testCase "parent embeds the nested struct at its std140 offsets" $ do + -- nested.comp: sun@0 (albedo@0, emission@16), tint@32 + let n = sizeOf scene + (al, em, ti) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) scene + (,,) + <$> (peekByteOff ptr 0 :: IO Float) + <*> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 32 :: IO Float) + alignment scene @?= 16 + sizeOf scene @?= 48 + al @?= 1.0 + em @?= 2.0 + ti @?= 3.0 + ] + , testGroup + "fixed-size array fields (Array n a)" + [ testCase "std140 rounds element stride up to 16" $ do + -- Kernel140: taps[4] vec4 @0 (stride 16), weights[4] float @64 (stride 16) + let n = sizeOf k140 + (t0, t1, w0, w1, w3) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) k140 + (,,,,) + <$> (peekByteOff ptr 0 :: IO Float) + <*> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 64 :: IO Float) + <*> (peekByteOff ptr 80 :: IO Float) -- std140 stride 16 + <*> (peekByteOff ptr 112 :: IO Float) + alignment k140 @?= 16 + sizeOf k140 @?= 128 + (t0, t1) @?= (1, 2) + (w0, w1, w3) @?= (10, 20, 40) + , testCase "std430 packs the float array tightly (stride 4)" $ do + -- Kernel430: taps[4] vec4 @0, weights[4] float @64 (stride 4) + let n = sizeOf k430 + (w0, w1, w3) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) k430 + (,,) + <$> (peekByteOff ptr 64 :: IO Float) + <*> (peekByteOff ptr 68 :: IO Float) -- std430 stride 4 + <*> (peekByteOff ptr 76 :: IO Float) + sizeOf k430 @?= 80 + (w0, w1, w3) @?= (10, 20, 40) + ] + , testGroup + "multi-dimensional array field (Array h (Array w a))" + [ testCase "std430 nested strides (inner 4, outer 16)" $ do + -- Grid430: head@0, grid[3][4] @16; grid[i][j] @ 16 + i*16 + j*4 + let n = sizeOf g430 + (h, g00, g01, g10, g23) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) g430 + (,,,,) + <$> (peekByteOff ptr 0 :: IO Float) + <*> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 20 :: IO Float) + <*> (peekByteOff ptr 32 :: IO Float) + <*> (peekByteOff ptr 60 :: IO Float) + sizeOf g430 @?= 64 + h @?= 9 + (g00, g01, g10, g23) @?= (1, 2, 5, 12) + , testCase "std140 nested strides (inner 16, outer 64)" $ do + -- Grid140: head@0, grid[3][4] @16; grid[i][j] @ 16 + i*64 + j*16 + let n = sizeOf g140 + (g00, g01, g10) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + poke (castPtr ptr) g140 + (,,) + <$> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 32 :: IO Float) -- inner stride 16 + <*> (peekByteOff ptr 80 :: IO Float) -- outer stride 64 + sizeOf g140 @?= 208 + (g00, g01, g10) @?= (1, 2, 5) + ] + , testGroup + "runtime-sized array (Storable.Vector at the std430 stride)" + [ testCase "elements placed at the array stride (32 > element size 20)" $ do + let + pads = VS.fromList [Pad (vec4 1 0 0 0) 2, Pad (vec4 9 0 0 0) 8] + stride = Array.std430Stride (Proxy :: Proxy Pad) + n = 2 * stride + (a0, b0, a1, b1) <- allocaBytes n $ \ptr -> do + fillBytes ptr 0 n + Array.pokeStd430 ptr pads + (,,,) + <$> (peekByteOff ptr 0 :: IO Float) + <*> (peekByteOff ptr 16 :: IO Float) + <*> (peekByteOff ptr 32 :: IO Float) -- second element at stride 32 + <*> (peekByteOff ptr 48 :: IO Float) + stride @?= 32 + (a0, b0, a1, b1) @?= (1, 2, 9, 8) + , testCase "round-trips through pokeStd430/peekStd430" $ do + let + pads = VS.fromList [Pad (vec4 1 2 3 4) 5, Pad (vec4 6 7 8 9) 10] + stride = Array.std430Stride (Proxy :: Proxy Pad) + rt <- allocaBytes (2 * stride) $ \ptr -> do + fillBytes ptr 0 (2 * stride) + Array.pokeStd430 ptr pads + Array.peekStd430 2 ptr + VS.toList rt @?= VS.toList pads + ] + , testGroup + "specialization constants from reflection" + [ testCase "reflects ids and names (ascending, non-contiguous)" $ do + m <- loadBytes Fixtures.specComp + specializationConstants m + @?= [(0, Just "count"), (3, Just "scale")] + , testCase "map entries keep real ids but pack tightly" $ do + m <- loadBytes Fixtures.specComp + let es = toL (specializationMapEntries m) + map (\e -> (e.constantID, e.offset, e.size)) es + @?= [(0, 0, 4), (3, 4, 4)] + ] + , testCase "descriptor set layout from reflection" $ do + m <- loadBytes Fixtures.juliaComp + case descriptorSetLayoutInfos m of + [(setNo, info)] -> do + setNo @?= 0 + let bs = toL info.bindings + map (.binding) bs @?= [0, 1] + map (.descriptorType) bs + @?= [Vk.DESCRIPTOR_TYPE_UNIFORM_BUFFER, Vk.DESCRIPTOR_TYPE_STORAGE_BUFFER] + all ((== Vk.SHADER_STAGE_COMPUTE_BIT) . (.stageFlags)) bs @? "all compute stage" + other -> assertFailure ("expected one set, got " <> show (length other)) + , testGroup + "vertex input from reflection" + [ testCase "attributes: format + tightly-packed offset" $ do + m <- loadBytes Fixtures.triVert + let attrs = vertexInputAttributes m + map (\a -> (a.location, a.format, a.offset)) attrs + @?= [ (0, Vk.FORMAT_R32G32B32_SFLOAT, 0) + , (1, Vk.FORMAT_R32G32_SFLOAT, 12) + , (2, Vk.FORMAT_R32G32B32A32_SFLOAT, 20) + ] + , testCase "binding stride is packed size" $ do + m <- loadBytes Fixtures.triVert + (vertexInputBinding m).stride @?= 36 + , testCase "vertexInputState packs the reflected binding + attributes" $ do + m <- loadBytes Fixtures.triVert + let vis = vertexInputState m + map (.stride) (toL vis.vertexBindingDescriptions) @?= [36] + map (.offset) (toL vis.vertexAttributeDescriptions) @?= [0, 12, 20] + , testCase "vertexInputState is empty when a module declares no vertex inputs" $ do + m <- loadBytes Fixtures.juliaComp + let vis = vertexInputState m + null (toL vis.vertexBindingDescriptions) @? "no bindings" + null (toL vis.vertexAttributeDescriptions) @? "no attributes" + ] + , testGroup + "type-level signatures" + [ testCase "a record's Sig reflects back to its value-level offset map (the oracle)" $ + -- Push: mat4 @0, vec2 @64, float @72, int @76, size 80. + layoutSig @Push + @?= normalize + ( fromFields + Std430Layout + Nothing + [ ("transform", Matrix STFloat 4 4) + , ("offset", Vector STFloat 2) + , ("scale", Scalar STFloat) + , ("count", Scalar STInt) + ] + ) + , testCase "layout-equivalent layouts promote to the SAME Sig (mat4 == vec4[4] == float[16])" $ do + layoutSig @EquivMat4 @?= layoutSig @EquivVec4x4 + layoutSig @EquivVec4x4 @?= layoutSig @EquivFloat16 + , testCase "Fits accepts layout-equivalent layouts at the type level" $ do + -- These only type-check because the 'Fits' constraints are satisfied. + mat4FitsVec4x4 @?= True + vec4x4FitsFloat16 @?= True + pushFitsItself @?= True + ] + , testGroup + "buffer (structural views)" + [ testCase "Storable size matches the layout signature size" $ + (layoutSig @PairA).size @?= Just (sizeOf (undefined :: PairA)) + , testCase "round-trips the same record" $ do + let a = PairA (vec4 9 8 7 6) (vec4 5 4 3 2) + buf <- newBuffer a + a' <- readBuffer buf + a' @?= a + , testCase "write one layout, read a layout-compatible one back (typed view)" $ do + buf <- newBuffer (PairA (vec4 1 2 3 4) (vec4 5 6 7 8)) + -- Fits (Sig PairB) (Sig PairA) holds because the layouts are equivalent. + PairB x y z w <- readBuffer buf + (x, y, z, w) @?= (vec2 1 2, vec2 3 4, vec2 5 6, vec2 7 8) + ] + , testGroup + "buffer (runtime-array element access)" + [ testCase "writes and reads back array elements by index" $ do + -- ArrayOf (Sig PairA): a runtime PairA[] (stride 32, base 0). + buf <- allocArrayBuffer @(ArrayOf (Sig PairA)) 2 + let + p0 = PairA (vec4 1 2 3 4) (vec4 5 6 7 8) + p1 = PairA (vec4 9 10 11 12) (vec4 13 14 15 16) + writeBufferElem buf 0 p0 + writeBufferElem buf 1 p1 + e0 <- readBufferElem buf 0 + e1 <- readBufferElem buf 1 + (e0, e1) @?= (p0, p1) + , testCase "reads an element back through a layout-compatible record (typed view)" $ do + buf <- allocArrayBuffer @(ArrayOf (Sig PairA)) 2 + writeBufferElem buf 0 (PairA (vec4 1 2 3 4) (vec4 5 6 7 8)) + writeBufferElem buf 1 (PairA (vec4 10 20 30 40) (vec4 50 60 70 80)) + -- FitsTail (Sig PairB) (ArrayOf (Sig PairA)) holds: the element layout is equivalent. + PairB x y z w <- readBufferElem buf 1 + (x, y, z, w) @?= (vec2 10 20, vec2 30 40, vec2 50 60, vec2 70 80) + ] + , testGroup + "stage interface matching" + [ testCase "vertex outputs reflect at locations 0 (vec3) and 1 (vec2)" $ do + vm <- loadBytes Fixtures.meshVert + let outs = (stageInfoOf vm).outputs + map fst outs @?= [0, 1] + map (length . (.slots) . snd) outs @?= [3, 2] + , testCase "vertex outputs match fragment inputs (value oracle)" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + matchInterface (stageInfoOf vm) (stageInfoOf fm) @?= Right () + , testCase "a mismatched interface is rejected (value oracle)" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + -- frag outputs (vec4 @loc0) cannot satisfy the vertex's own inputs. + assertBool "should not match" (isLeft (matchInterface (stageInfoOf fm) (stageInfoOf vm))) + , testCase "MatchInterface holds at the type level" $ + meshInterfaceOk @?= True + ] + , testGroup + "stage resource linking (shared UBO)" + [ testCase "the Scene UBO reflects identically from both stages" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + lookup (0, 0) (stageInfoOf vm).resources + @?= lookup (0, 0) (stageInfoOf fm).resources + , testCase "linking unions resources, push and the external interface" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + case linkStages (stageInfoOf vm) (stageInfoOf fm) of + Left e -> assertFailure e + Right linked -> do + map fst linked.resources @?= [(0, 0), (0, 1)] -- Scene (shared) + Materials + isJust linked.push @?= True -- vertex Model push constant + map fst linked.inputs @?= [0, 1, 2] -- vertex attributes + map fst linked.outputs @?= [0] -- fragment colour output + , testCase "a conflicting shared binding is rejected" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + let bad = + (stageInfoOf fm) + { StageInfo.resources = [((0, 0), normalize (fromFields Std140Layout Nothing [("x", Vector STFloat 2)]))] + } + assertBool "should conflict" (isLeft (linkStages (stageInfoOf vm) bad)) + , testCase "CompatibleResources holds at the type level" $ + meshResourcesOk @?= True + , testCase "the merged layout signature round-trips to the value-level merge" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + let info = layoutSigVal (Proxy @MeshLayout) -- reflected from the promoted type + mergeLayout [vm, fm] @?= Right info -- equals the value-level merge + map fst info.resources @?= [(0, 0), (0, 1)] -- Scene (shared) + Materials + isJust info.push @?= True -- vertex Model push constant + ] + , testGroup + "pipeline layout (depth-only vs depth+color from one vertex shader)" + [ testCase "depth-only: the vertex stage alone" $ do + vm <- loadBytes Fixtures.meshVert + -- Only the vertex-visible resources: Scene UBO at (0,0), vertex stage. + stageBindings [vm] + @?= [(0, Vk.SHADER_STAGE_VERTEX_BIT)] + fmap length (mergedPushConstantRanges [vm]) @?= Right 1 -- the Model push constant + , testCase "depth+color: vertex+fragment, Scene gains the fragment stage" $ do + vm <- loadBytes Fixtures.meshVert + fm <- loadBytes Fixtures.meshFrag + stageBindings [vm, fm] + @?= [ (0, Vk.SHADER_STAGE_VERTEX_BIT .|. Vk.SHADER_STAGE_FRAGMENT_BIT) -- Scene, shared + , (1, Vk.SHADER_STAGE_FRAGMENT_BIT) -- Materials, frag-only + ] + ] + , LayoutSpec.tests + ] + where + -- (binding, stageFlags) across all sets, for the merged pipeline layout. + stageBindings modules = + sortOn + fst + [ (b.binding, b.stageFlags) + | (_set, info) <- either error id (mergedDescriptorSetLayoutInfos modules) + , b <- V.toList info.bindings + ] + params = + Params + { center = vec2 (-0.8) 0.156 + , resolution = uvec2 512 512 + , escapeRadius = 2.0 + , maxIterations = 1000 + } + pushc = + Push + { transform = identity + , offset = vec2 1 2 + , scale = 2.5 + , count = 7 + } + wide = + Wide + { hi = 0xDEADBEEFCAFEF00D + , lo = -42 + , tag = 7 + } + particle = + Particle + { position = vec3 (-1) 0 0 + , velocity = vec2 3 4 + , mass = 1.5 + , flags = 7 + } + mat = + Material + { albedo = vec4 1 0 0 0 + , emission = vec4 2 0 0 0 + } + scene = + Scene + { sun = mat + , tint = vec4 3 0 0 0 + } + taps = Array.unsafeFromList [vec4 1 0 0 0, vec4 2 0 0 0, vec4 3 0 0 0, vec4 4 0 0 0] :: Array.Array 4 Vec4 + weights = Array.unsafeFromList [10, 20, 30, 40] :: Array.Array 4 Float + k140 = Kernel140{taps = taps, weights = weights} + k430 = Kernel430{taps = taps, weights = weights} + grid = + Array.unsafeFromList (map Array.unsafeFromList [[1, 2, 3, 4], [5, 6, 7, 8], [9, 10, 11, 12]]) + :: Array.Array 3 (Array.Array 4 Float) + g430 = Grid430{head = vec4 9 0 0 0, grid = grid} + g140 = Grid140{head = vec4 9 0 0 0, grid = grid} + toL = foldr (:) [] diff --git a/vulkan-utils-spirv.cabal b/vulkan-utils-spirv.cabal new file mode 100644 --- /dev/null +++ b/vulkan-utils-spirv.cabal @@ -0,0 +1,143 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.39.6. +-- +-- see: https://github.com/sol/hpack + +name: vulkan-utils-spirv +version: 0.1.0.0 +synopsis: Generate Haskell types and Vulkan descriptor/pipeline layouts from SPIR-V reflection +category: Graphics +homepage: https://github.com/haskell-game/vulkan#readme +bug-reports: https://github.com/haskell-game/vulkan/issues +maintainer: IC Rainbow +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + package.yaml + +source-repository head + type: git + location: https://github.com/haskell-game/vulkan + +library + exposed-modules: + Vulkan.Utils.SpirV.Array + Vulkan.Utils.SpirV.Block + Vulkan.Utils.SpirV.Buffer + Vulkan.Utils.SpirV.Descriptors + Vulkan.Utils.SpirV.DeviceAddress + Vulkan.Utils.SpirV.Layout + Vulkan.Utils.SpirV.Pipeline + Vulkan.Utils.SpirV.Reflect + Vulkan.Utils.SpirV.Reflect.OffsetMaps + Vulkan.Utils.SpirV.Signature + Vulkan.Utils.SpirV.Specialization + Vulkan.Utils.SpirV.Stage + Vulkan.Utils.SpirV.TH + Vulkan.Utils.SpirV.Types + Vulkan.Utils.SpirV.VertexInput + other-modules: + Paths_vulkan_utils_spirv + autogen-modules: + Paths_vulkan_utils_spirv + hs-source-dirs: + src + default-extensions: + BlockArguments + DataKinds + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + ImportQualifiedPost + LambdaCase + NamedFieldPuns + OverloadedRecordDot + OverloadedStrings + PatternSynonyms + RecordWildCards + ScopedTypeVariables + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeOperators + ViewPatterns + ghc-options: -Wall + build-depends: + base >=4.16 && <5 + , bytestring + , containers + , gl-block + , ptrdiff + , resourcet + , spirv-enum + , spirv-reflect-ffi + , spirv-reflect-types + , template-haskell + , text + , unliftio-core + , vector + , vulkan ==3.27.* + , vulkan-utils + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Fixtures + LayoutSpec + Paths_vulkan_utils_spirv + autogen-modules: + Paths_vulkan_utils_spirv + hs-source-dirs: + test + default-extensions: + BlockArguments + DataKinds + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + ImportQualifiedPost + LambdaCase + NamedFieldPuns + OverloadedRecordDot + OverloadedStrings + PatternSynonyms + RecordWildCards + ScopedTypeVariables + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeOperators + ViewPatterns + ghc-options: -Wall + build-depends: + base <5 + , bytestring + , containers + , geomancy + , gl-block + , spirv-reflect-ffi + , spirv-reflect-types + , tasty + , tasty-hunit + , template-haskell + , text + , vector + , vulkan + , vulkan-utils + , vulkan-utils-spirv + default-language: Haskell2010