diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# `fir` – Changelog + +## 0.1.0.0 – 2026-11-06 + +First Hackage release, with the historical EDSL as it was circa 2022. diff --git a/fir.cabal b/fir.cabal new file mode 100644 --- /dev/null +++ b/fir.cabal @@ -0,0 +1,481 @@ +cabal-version: 3.0 +name: fir +version: 0.1.0.0 +synopsis: An EDSL that compiles to SPIR-V for graphics programming on the GPU in Haskell. +category: Graphics +author: Sam Derbyshire +maintainer: sam.derbyshire@gmail.com +license: BSD-3-Clause +homepage: https://gitlab.com/sheaf/fir +bug-reports: https://gitlab.com/sheaf/fir/-/issues +build-type: Simple +tested-with: GHC == 9.14.1 +extra-doc-files: + CHANGELOG.md + img/FIR_logo.svg +extra-source-files: + test/Tests/**/*.hs + test/Tests/**/*.golden +description: + + <> + + [__FIR__](https://gitlab.com/sheaf/fir) is an EDSL + for writing GPU shader code in Haskell, compiled to __@SPIR-V@__. + Requires GHC >= 8.10. + + With this library, shader programs can be written using @do@ notation. + Such programs are then transformed into abstract syntax trees (ASTs), + before being compiled to @SPIR-V@ assembly. + + In effect, this replaces @GLSL@ as a shader language. + This means the Haskell type-system and type-checker are put to use + in verifying programs at compile-time. + Functional idioms, such as functor and applicative operations, are also supported. + + See the [fir-examples](https://gitlab.com/sheaf/fir/tree/0.1/fir-examples) + project subdirectory for fleshed out examples, + including using the @vulkan@ package for rendering. + + The exposed modules are: + + ["FIR"] + Re-exports the main functionality of the library: writing and compiling programs. + + + ["FIR.Syntax.Labels"] + Optional imperative-like syntax using /OverloadedLabels/. + + + ["Math.Linear"] + Vectors, matrices, and operations on them, as used by this library. + + + ["Math.Quaternion"] + Quaternions and their action by conjugation in 3 dimensions, useful for 3D cameras. + + + + Important types used by this library: + + [@Code a@] + + Code for a pure value of type @a@, represented internally as an abstract syntax tree. + See "FIR.AST". + + Overloaded functions are provided that automatically create and combine terms of this type. + For instance, @3 + 5 :: Code Float@ gets desugared to @PrimOp FAdd ( Lit 3.0 ) ( Lit 5.0 )@. + + [@Program i j a@] + + A monadic expression, starting in state @i@ and ending in state @j@. + This state is used to keep track of information at the type level, + allowing for type errors to be thrown on invalid operations + (e.g. writing to a read-only variable, image sampling outside a fragment shader, etc). + + A value of type @Program i j (Code a)@ can be thought of as stateful GPU code + producing a value of type @a@. + + Internally represented using the codensity transformation of McBride-style indexed monads, see "Control.Monad.Indexed". + + [@Module defs@] + + Code for a program that can be compiled to a @SPIR-V@ module. + + @defs@ is a type-level list of shader inputs/ouputs (uniforms, varyings, etc), + top-level functions, and entry points. + + See "FIR.Module" for the definition, and the [example shaders](https://gitlab.com/sheaf/fir/tree/0.1/fir-examples/readme.md#overview) + for common usage patterns. + + + Values of all three of these types can be displayed graphically as trees using @showAST@/@drawAST@, + which can be useful for debugging. + + See the [project readme](https://gitlab.com/sheaf/fir/tree/0.1/readme.md) for further information, + as well as the ["getting started" guide](https://gitlab.com/sheaf/fir/tree/0.1/getting_started.md), + which includes instructions concerning installation and usage of the library, and of useful tools + such as the @SPIR-V@ tools provided by the [Vulkan SDK](https://www.lunarg.com/vulkan-sdk/). + +source-repository head + type: git + location: https://gitlab.com/sheaf/fir.git + branch: 0.1 + +flag internals + + manual: True + default: False + description: This flag exposes all internal modules that by default are + inaccessible. It's mostly only useful for library developers to + use the internals of FIR rather than end users writing shader + programs. + +flag sop + + manual: True + default: False + description: This flag exposes a module with Syntactic instances for generics-sop. + + +common common + + build-depends: + base + >= 4.14 && < 4.23 + , bytestring + >= 0.10.9.0 && < 0.13 + , directory + ^>= 1.3.3.0 + +common test + + build-depends: + filepath + >= 1.4.2.1 && < 1.6 + , process + ^>= 1.6.3.0 + , text + >= 1.2.3.1 && < 2.2 + +library + + import: + common + + hs-source-dirs: + src + + exposed-modules: + FIR + , FIR.Syntax.DebugPrintf + , FIR.Syntax.Labels + , Math.Linear + , Math.Quaternion + + if flag(sop) + exposed-modules: + , FIR.Generics + + if flag(internals) + exposed-modules: + , CodeGen.Application + , CodeGen.Applicative + , CodeGen.Array + , CodeGen.Atomics + , CodeGen.Binary + , CodeGen.CFG + , CodeGen.CodeGen + , CodeGen.Composite + , CodeGen.Debug + , CodeGen.Functions + , CodeGen.IDs + , CodeGen.Images + , CodeGen.Instruction + , CodeGen.Monad + , CodeGen.Optics + , CodeGen.Phi + , CodeGen.Pointers + , CodeGen.PrimOps + , CodeGen.RayTracing + , CodeGen.State + , Control.Arrow.Strength + , Control.Monad.Indexed + , Control.Type.Optic + , Data.Binary.Class.Put + , Data.Constraint.All + , Data.Containers.Traversals + , Data.Finite.With + , Data.Function.Variadic + , Data.Product + , Data.Type.Error + , Data.Type.Known + , Data.Type.LazyEquality + , Data.Type.List + , Data.Type.Map + , Data.Type.Maybe + , Data.Type.Nat + , Data.Type.POrd + , Data.Type.Snoc + , Data.Type.String + , Deriving.Base + , FIR.AST + , FIR.AST.ControlFlow + , FIR.AST.Display + , FIR.AST.Images + , FIR.AST.Type + , FIR.AST.Effs + , FIR.AST.Exts + , FIR.AST.Optics + , FIR.AST.Prim + , FIR.Binding + , FIR.Builtin + , FIR.Definition + , FIR.Layout + , FIR.Module + , FIR.Pipeline + , FIR.Prelude + , FIR.Prim.Array + , FIR.Prim.Image + , FIR.Prim.RayTracing + , FIR.Prim.Atomic + , FIR.Prim.Struct + , FIR.Prim.Types + , FIR.Prim.Op + , FIR.ProgramState + , FIR.Syntax.AST + , FIR.Syntax.Complex + , FIR.Syntax.IfThenElse + , FIR.Syntax.Images + , FIR.Syntax.Optics + , FIR.Syntax.Option + , FIR.Syntax.Program + , FIR.Syntax.RayTracing + , FIR.Syntax.Swizzle + , FIR.Syntax.Synonyms + , FIR.Validation.Ambiguity + , FIR.Validation.Arrayness + , FIR.Validation.Bindings + , FIR.Validation.Bounds + , FIR.Validation.CFG + , FIR.Validation.Definitions + , FIR.Validation.ExecutionModes + , FIR.Validation.Formats + , FIR.Validation.Images + , FIR.Validation.Interface + , FIR.Validation.Layout + , FIR.Validation.Pipeline + , FIR.Validation.RayTracing + , FIR.Temp + , Instances.TH.Lift + , Math.Algebra.Class + , Math.Algebra.GradedSemigroup + , Math.Logic.Bits + , Math.Logic.Class + , SPIRV.Builtin + , SPIRV.Capability + , SPIRV.Control + , SPIRV.Decoration + , SPIRV.ExecutionMode + , SPIRV.Extension + , SPIRV.Groups + , SPIRV.Image + , SPIRV.Layout + , SPIRV.Operation + , SPIRV.PrimOp + , SPIRV.PrimTy + , SPIRV.Requirements + , SPIRV.ScalarTy + , SPIRV.Stage + , SPIRV.Storage + , SPIRV.Synchronisation + , SPIRV.Version + else + other-modules: + CodeGen.Application + , CodeGen.Applicative + , CodeGen.Array + , CodeGen.Atomics + , CodeGen.Binary + , CodeGen.CFG + , CodeGen.CodeGen + , CodeGen.Composite + , CodeGen.Debug + , CodeGen.Functions + , CodeGen.IDs + , CodeGen.Images + , CodeGen.Instruction + , CodeGen.Monad + , CodeGen.Optics + , CodeGen.Phi + , CodeGen.Pointers + , CodeGen.PrimOps + , CodeGen.RayTracing + , CodeGen.State + , Control.Arrow.Strength + , Control.Monad.Indexed + , Control.Type.Optic + , Data.Binary.Class.Put + , Data.Constraint.All + , Data.Containers.Traversals + , Data.Finite.With + , Data.Function.Variadic + , Data.Product + , Data.Type.Error + , Data.Type.Known + , Data.Type.LazyEquality + , Data.Type.List + , Data.Type.Map + , Data.Type.Maybe + , Data.Type.Nat + , Data.Type.POrd + , Data.Type.Snoc + , Data.Type.String + , Deriving.Base + , FIR.AST + , FIR.AST.ControlFlow + , FIR.AST.Display + , FIR.AST.Images + , FIR.AST.Type + , FIR.AST.Effs + , FIR.AST.Exts + , FIR.AST.Optics + , FIR.AST.Prim + , FIR.Binding + , FIR.Builtin + , FIR.Definition + , FIR.Layout + , FIR.Module + , FIR.Pipeline + , FIR.Prelude + , FIR.Prim.Array + , FIR.Prim.Image + , FIR.Prim.RayTracing + , FIR.Prim.Atomic + , FIR.Prim.Struct + , FIR.Prim.Types + , FIR.Prim.Op + , FIR.ProgramState + , FIR.Syntax.AST + , FIR.Syntax.Complex + , FIR.Syntax.IfThenElse + , FIR.Syntax.Images + , FIR.Syntax.Optics + , FIR.Syntax.Option + , FIR.Syntax.Program + , FIR.Syntax.RayTracing + , FIR.Syntax.Swizzle + , FIR.Syntax.Synonyms + , FIR.Validation.Ambiguity + , FIR.Validation.Arrayness + , FIR.Validation.Bindings + , FIR.Validation.Bounds + , FIR.Validation.CFG + , FIR.Validation.Definitions + , FIR.Validation.ExecutionModes + , FIR.Validation.Formats + , FIR.Validation.Images + , FIR.Validation.Interface + , FIR.Validation.Layout + , FIR.Validation.Pipeline + , FIR.Validation.RayTracing + , FIR.Temp + , Instances.TH.Lift + , Math.Algebra.Class + , Math.Algebra.GradedSemigroup + , Math.Logic.Bits + , Math.Logic.Class + , SPIRV.Builtin + , SPIRV.Capability + , SPIRV.Control + , SPIRV.Decoration + , SPIRV.ExecutionMode + , SPIRV.Extension + , SPIRV.Groups + , SPIRV.Image + , SPIRV.Layout + , SPIRV.Operation + , SPIRV.PrimOp + , SPIRV.PrimTy + , SPIRV.Requirements + , SPIRV.ScalarTy + , SPIRV.Stage + , SPIRV.Storage + , SPIRV.Synchronisation + , SPIRV.Version + + + build-depends: + atomic-file-ops + ^>= 0.3.0.0 + , binary + >= 0.8.7.0 && < 0.11 + , containers + >= 0.6.2.1 && < 0.9 + , distributive + ^>= 0.6 + , finite-typelits + >= 0.1.4.2 && < 0.3 + , generic-monoid + ^>= 0.1.0.0 + , ghc-typelits-knownnat + ^>= 0.8.2 + , ghc-typelits-natnormalise + ^>= 0.9.0 + , half + ^>= 0.3 + , lens + >= 4.18 && < 5.4 + , mtl + >= 2.2.2 && < 2.4 + , split + >= 0.2.3.3 && < 0.3 + , template-haskell + >= 2.15 && < 2.25 + , text-short + >= 0.1.4 && < 0.2 + , transformers + >= 0.5.6.2 && < 0.7 + , tree-view + ^>= 0.5 + , typelits-witnesses + >= 0.2.3 && < 0.5 + , variant + ^>= 1.0.1 + , vector + >= 0.12.0.3 && < 0.14 + , vector-sized + >= 1.4.0.0 && < 1.7 + + if flag(sop) + build-depends: + , generics-sop + >= 0.4 && < 0.5.2 + , sop-core + >= 0.4 && < 0.5.1 + + default-language: + Haskell2010 + + default-extensions: + NoStarIsType + + ghc-options: + -Wall + -Wcompat + -fno-warn-orphans + -fno-warn-unticked-promoted-constructors + -fno-warn-unused-do-bind + -fwarn-missing-local-signatures + -fwarn-incomplete-uni-patterns + -fwarn-missing-deriving-strategies + + if impl(ghc >= 9.14) + ghc-options: + -Wno-pattern-namespace-specifier + +test-suite fir-tests + + import: common, test + + type: + detailed-0.9 + + hs-source-dirs: + test + + test-module: + CabalTests + + other-modules: + Test + , Tests + , Folders + + build-depends: + fir + , Cabal + >= 3.0.0.0 && < 3.17 + + default-language: + Haskell2010 diff --git a/img/FIR_logo.svg b/img/FIR_logo.svg new file mode 100644 --- /dev/null +++ b/img/FIR_logo.svg @@ -0,0 +1,142 @@ + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + + + + + + + + + + + + diff --git a/src/CodeGen/Application.hs b/src/CodeGen/Application.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Application.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +{-| +Module: CodeGen.Application + +Functionality for keeping track of function arguments, such as patterns for the application of a function to several arguments. +-} + +module CodeGen.Application + ( UAST(..), UCode(..) + , ASTs(.., SnocAST) + , Codes, pattern ConsCode + , Application(.., Nullary) + , traverseASTs + ) where + +-- base +import Data.Kind + ( Type ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- fir +import Data.Constraint.All + ( All(allDict) + , AllDict(ConsDict) + ) +import Data.Type.List + ( Head, Tail, Snoc ) +import FIR.AST + ( AST, Code ) +import FIR.AST.Type + ( AugType, FunTys, Nullary, MapVal ) + +---------------------------------------------------------------------------- +-- existential data types to emulate untyped AST + +-- UAST = Untyped AST +data UAST where + UAST :: AST a -> UAST +deriving stock instance Show UAST + +data UCode where + UCode :: Nullary a => AST a -> UCode +deriving stock instance Show UCode + +---------------------------------------------------------------------------- +-- typed list of ASTs + +infixr 5 `ConsAST` +infixl 5 `SnocAST` + +data ASTs (is :: [AugType]) :: Type where + NilAST :: ASTs '[] + ConsAST :: AST i -> ASTs is -> ASTs (i ': is) + +{-# COMPLETE SnocAST #-} +pattern SnocAST :: ASTs as -> AST a -> ASTs (as `Snoc` a) +pattern SnocAST as a <- ( unsnocAST -> (as, a) ) + where + SnocAST NilAST a = a `ConsAST` NilAST + SnocAST (x `ConsAST` xs) a = unsafeCoerce ( x `ConsAST` (xs `SnocAST` a) ) + -- ^^^^ + -- should be able to get rid of this @unsafeCoerce@ + +unsnocAST :: ASTs (as `Snoc` a) -> ( ASTs as, AST a ) +unsnocAST NilAST = error "impossible" +unsnocAST (b `ConsAST` NilAST) = unsafeCoerce ( NilAST, b ) +unsnocAST (b `ConsAST` bs ) = + case unsnocAST ( unsafeCoerce bs ) of + ( cs, c ) -> ( unsafeCoerce (b `ConsAST` cs), c ) + +type Codes as = ASTs (MapVal as) + +data Application (ast :: AugType -> Type) (f :: AugType) (r :: AugType) where + Applied :: FunTys f as r => ast f -> ASTs as -> Application ast f r + +pattern Nullary :: FunTys f '[] r => ast f -> Application ast f r +pattern Nullary v = Applied v NilAST + +traverseASTs + :: forall c f as b + . ( Applicative f, All c as ) + => ( forall a. c a => AST a -> f b ) + -> ASTs as + -> f [b] +traverseASTs f as = go allDict as + where + go :: AllDict c xs -> ASTs xs -> f [b] + go _ NilAST = pure [] + go ConsDict (x `ConsAST` xs) = (:) <$> f x <*> go allDict xs + +---------------------------------------------------------------------------- +-- Workaround for pattern matching not correctly propagating type family injectivity annotations +-- (See [GHC trac #16436](https://gitlab.haskell.org/ghc/ghc/issues/16436).) + +infixr 5 `ConsCode` + +pattern ConsCode :: () => ( as ~ ( Head as ': Tail as ) ) + => Code (Head as) -> Codes (Tail as) -> Codes as +pattern ConsCode b bs <- ( getConsCode -> Just (GetConsCode b bs) ) + where + ConsCode b bs = ConsAST b bs + +data GetConsCode as where + GetConsCode :: ( as ~ (Head as ': Tail as) ) => Code (Head as) -> Codes (Tail as) -> GetConsCode as + +getConsCode :: forall as. Codes as -> Maybe (GetConsCode as) +getConsCode NilAST = Nothing +getConsCode (ConsAST a as) = case unsafeCoerce Refl :: ( as :~: (Head as ': Tail as) ) of + Refl -> Just (GetConsCode a as) diff --git a/src/CodeGen/Applicative.hs b/src/CodeGen/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Applicative.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-| +Module: CodeGen.Applicative + +Code generation for (functor and) applicative operations: + + * vectors use vectorised instructions (whenever possible), + * matrices use vectorised operations on their columns (whenever possible), + * arrays use loops. + +-} + +module CodeGen.Applicative ( ) where + +-- base +import Prelude + hiding ( Num(..), Integral(..) + , Fractional(..), Floating(..), RealFloat(..) + ) +import qualified Prelude +import Data.Foldable + ( toList ) +import Data.Kind + ( Type ) +import Data.Proxy + ( Proxy(Proxy) ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import Data.Word + ( Word32 ) +import GHC.TypeNats + ( Nat, KnownNat ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- lens +import Control.Lens + ( assign ) + +-- mtl +import Control.Monad.Except + ( throwError ) + +-- text-short +import qualified Data.Text.Short as ShortText + ( pack ) + +-- variant +import Data.Variant.VariantF + ( VariantF, ApplyAll, BottomUp(toBottomUp) ) +import Data.Variant.EGADT + ( EGADT(..), HVariantF(..) ) + +-- fir +import CodeGen.Application + ( Application(Applied) + , ASTs(NilAST, ConsAST) + , pattern SnocAST + , pattern Nullary + ) +import CodeGen.Array + ( createArray ) +import {-# SOURCE #-} CodeGen.CodeGen + ( CodeGen(codeGenArgs), codeGen ) +import CodeGen.Composite + ( compositeConstruct ) +import CodeGen.Instruction + ( ID, Pointer(..) ) +import CodeGen.Monad + ( CGMonad ) +import CodeGen.Pointers + ( newVariable ) +import CodeGen.State + ( _localBinding, scoped ) +import Control.Type.Optic + ( AnIndex + , ReifiedGetter(view) + ) +import Data.Constraint.All + ( All(allDict), AllDict(NilDict, ConsDict) ) +import Data.Type.Known + ( knownValue ) +import Data.Type.List + ( Snoc ) +import FIR.AST + ( Code, AST + , Syntactic(fromAST) + , primOp + , AppF(..), LitF(..) + , ApplicativeF(..) + , PrimOpF(..), MkVectorF(..) + , UnsafeCoerceF(..) + , pattern (:$), pattern Lam, pattern Pure, pattern MkID + , pattern MkVector, pattern UnMat + , pattern UnsafeCoerce, pattern Lit + ) +import FIR.AST.Type + ( AugType(Val,(:-->)), UnderlyingType + , FunArgs, FunRes, ApplyFun + , ApplyFAug, MapApplyFAug + ) +import FIR.Prim.Array + ( Array ) +import FIR.Prim.Op + ( PrimOp(..), SPrimOp(SMul) + , Vectorise(Vectorise), VecPrimOpType(VecPrimOpType) + , PrimTyVal + ) +import FIR.Prim.Types + ( PrimTy, primTy + , IntegralTy + , PrimFunc(primFuncSing, distDict), DistDict(DistDict) + , SPrimFunc(..) + ) +import FIR.Syntax.AST + ( ) -- 'PrimFunc' instances, optic instances +import Math.Algebra.Class + ( Semiring((*)), Integral ) +import Math.Linear + ( V, M, Semimodule((*^)) ) +import qualified SPIRV.PrimTy as SPIRV + +---------------------------------------------------------------------------- +-- Dispatch code-generation on AST constructors. + +instance CodeGen AST => CodeGen (ApplicativeF AST) where + + codeGenArgs ( Applied ( ApF pxf (Pure _ f :: AST (Val (f a) :--> ApplyFAug f b )) (Pure _ a :: AST (Val (f a))) ) as ) + | ( _ :: AST t ) <- f + , ( _ :: AST v ) <- a + , Refl <- ( unsafeCoerce Refl :: t :~: ( Val a :--> b ) ) + , Refl <- ( unsafeCoerce Refl :: v :~: Val a ) + , ConsDict <- allDict @PrimTyVal @(Val a ': FunArgs b) + = codeGenArgs ( Applied ( PureF pxf (f :$ a) ) as ) + codeGenArgs ( Applied ( ApF ( _ :: Proxy f) f a ) as ) = + codeGenArgs ( Applied f (a `ConsAST` as) ) + + codeGenArgs ( Applied (PureF ( _ :: Proxy f) (a :: AST a)) (as :: ASTs fas) ) + | Refl <- ( unsafeCoerce Refl :: ApplyFun a fas :~: Val (UnderlyingType (FunRes a)) ) + , Refl <- ( unsafeCoerce Refl :: fas :~: MapApplyFAug f (FunArgs a) ) + = idiom (makeIdiom @f @a @(FunArgs a) a as) + + +makeIdiom + :: forall f a as fas + . ( fas ~ MapApplyFAug f as, All PrimTyVal as ) + => AST a -> ASTs fas -> Idiom f as (ApplyFun a fas) +makeIdiom v NilAST + | Refl <- ( unsafeCoerce Refl :: ApplyFun a fas :~: a ) + , Refl <- ( unsafeCoerce Refl :: as :~: '[] ) + = PureIdiom v +makeIdiom h as@(ConsAST _ _) = case snocDict ( allDict @PrimTyVal @as ) of + sDict@SnocDict + | ( _ :: SnocDict PrimTyVal (init_as `Snoc` last_as) ) <- sDict + , ( _ :: Proxy init_fas ) <- Proxy @( MapApplyFAug f init_as ) + , Refl <- ( unsafeCoerce Refl :: fas :~: ( init_fas `Snoc` (ApplyFAug f last_as) ) ) + , ( bs `SnocAST` b ) <- as + , ( nxt :: Idiom f init_as (ApplyFun a init_fas ) ) <- makeIdiom h bs + , Refl <- ( unsafeCoerce Refl :: ApplyFun a init_fas :~: ( Val (UnderlyingType last_as) :--> ApplyFun a fas ) ) + -> ApIdiom nxt b + +data Idiom (f :: Type -> Type) (as :: [AugType]) (b :: AugType) where + PureIdiom :: forall f b. AST b -> Idiom f '[] b + ApIdiom :: PrimTy a => Idiom f as (Val a :--> b) -> AST (Val (f a)) -> Idiom f (as `Snoc` (Val a)) b +deriving stock instance Show (Idiom f as b) + +data SnocDict c as where + NilSnocDict :: SnocDict c '[] + SnocDict :: (All c as, c a) => SnocDict c (as `Snoc` a) + +snocDict :: forall c as. AllDict c as -> SnocDict c as +snocDict NilDict = NilSnocDict +snocDict consDict@ConsDict = case consDict of + ( _ :: AllDict c (b ': bs) ) -> case snocDict (allDict @c @bs) of + NilSnocDict -> SnocDict + sDict@SnocDict -> case sDict of + ( _ :: SnocDict c (xs `Snoc` x ) ) + | Refl <- ( unsafeCoerce Refl :: as :~: ( (b ': xs) `Snoc` x) ) + -> SnocDict + +---------------------------------------------------------------------------- +-- Code-generation of an idiomatic expression. + +idiom + :: forall f bs r + . ( CodeGen AST, PrimFunc f, PrimTy r ) + => Idiom f bs (Val r) -> CGMonad ( ID, SPIRV.PrimTy ) +idiom (PureIdiom b) = do + elt@(eltID, eltTy) <- codeGen b + case primFuncSing @f of + sFuncVector@SFuncVector -> + case sFuncVector of + ( _ :: SPrimFunc (V n) ) -> + let n :: Prelude.Num t => t + n = Prelude.fromIntegral (knownValue @n) + in compositeConstruct + ( SPIRV.Vector n eltTy ) + ( replicate n eltID ) + sFuncMatrix@SFuncMatrix -> + case sFuncMatrix of + ( _ :: SPrimFunc (M m n) ) -> + do + constituentTy <- + case eltTy of + SPIRV.Scalar ty -> pure ty + ty -> throwError + ( "codeGen: matrix contains non-scalars of type " + <> ShortText.pack (show ty) + ) + let colDim :: Word32 + colDim = knownValue @m + rowDim :: Prelude.Num t => t + rowDim = Prelude.fromIntegral (knownValue @n) + col <- fst <$> idiom ( PureIdiom @(V m) (MkID elt :: Code r) ) + compositeConstruct + ( SPIRV.Matrix colDim rowDim constituentTy ) + ( replicate rowDim col ) + sFuncArray@SFuncArray -> + case sFuncArray of + ( _ :: SPrimFunc (Array n) ) -> + let n :: Prelude.Num t => t + n = Prelude.fromIntegral (knownValue @n) + in compositeConstruct + ( SPIRV.Array n eltTy ) + ( replicate n eltID ) +idiom apIdiom@(ApIdiom idi a) = + case primFuncSing @f of + sFuncVector@SFuncVector -> + case sFuncVector of + ( _ :: SPrimFunc (V n) ) -> + case applyIdiomV @n apIdiom of + -- attempt to directly vectorise operation if possible + Just res -> codeGen res + -- otherwise, revert to doing it component by component + _ -> do + ids <- toList <$> traverse codeGen (applyIdiom idi a) + eltTy <- case ids of + ((_, ty) : _) -> pure ty + _ -> throwError "codeGen: empty vector" + compositeConstruct + ( SPIRV.Vector (knownValue @n) eltTy ) + ( map fst ids ) + sFuncMatrix@SFuncMatrix -> + case sFuncMatrix of + ( _ :: SPrimFunc (M m n) ) -> + let idiom_cols :: V n (Idiom (V m) bs (Val r)) + idiom_cols = distributeMatrixIdiom apIdiom + in do + cols <- toList <$> traverse idiom idiom_cols + eltTy <- case cols of + ((_, SPIRV.Vector _ (SPIRV.Scalar ty)) : _) + -> pure ty + _ -> throwError "codeGen: invalid matrix type, columns are not vectors of scalars" + compositeConstruct + ( SPIRV.Matrix (knownValue @m) (knownValue @n) eltTy ) + ( map fst cols ) + sFuncArray@SFuncArray -> + case sFuncArray of + ( _ :: SPrimFunc (Array n) ) -> + let arrayFunction = applyIdiomArray @n @Word32 idi a + arrayLg = knownValue @n + eltTy = primTy @r + in do + Pointer resArrPtrID resArrPtrTy <- newVariable ( SPIRV.Array arrayLg eltTy ) + ( res, _ ) <- scoped do + assign ( _localBinding "__tmp_array" ) ( Just ( resArrPtrID, SPIRV.Pointer resArrPtrTy ) ) + assign ( _localBinding "__tmp_arrayIndex" ) Nothing + codeGen ( createArray @n @"__tmp_array" @"__tmp_arrayIndex" @r arrayFunction ) + return res + + +applyIdiom + :: forall f as a b + . ( PrimFunc f, PrimTy a ) + => Idiom f as (Val a :--> b) -> AST (Val (f a)) -> f (AST b) +applyIdiom i a + | DistDict <- distDict @f @(AST (Val a)) + = case i of + PureIdiom f -> fromAST f <$> ( fromAST a :: f (AST (Val a)) ) + ApIdiom f a' -> ( fromAST <$> applyIdiom f a' ) <*> ( fromAST a :: f (AST (Val a)) ) + +distributeMatrixIdiom + :: forall m n as b. + ( KnownNat m, KnownNat n ) + => Idiom (M m n) as b -> V n (Idiom (V m) as b) +distributeMatrixIdiom (PureIdiom f) + = fmap PureIdiom . pure @(V n) $ f +distributeMatrixIdiom (ApIdiom f a) + = ApIdiom <$> distributeMatrixIdiom f <*> fromAST ( UnMat :$ a ) + + +applyIdiomArray + :: forall n ix as a b + . ( KnownNat n + , Integral ix, IntegralTy ix + , PrimTy a + ) + => Idiom (Array n) as (Val a :--> b) -> Code (Array n a) -> ( Code ix -> AST b ) +applyIdiomArray (PureIdiom f) arr i = + fromAST f (view @(AnIndex (Code ix)) i arr) +applyIdiomArray (ApIdiom f arr') arr i = + let f' :: Code a -> AST b + f' = fromAST ( applyIdiomArray f arr' i ) + in f' (view @(AnIndex (Code ix)) i arr) + +--------------------------------------------------------------------------------------- +-- awful hacks to use native SPIR-V vectorised instructions if possible + +newtype FakeScalar n a = FakeScalar a + deriving stock Show + +type family Vectorisation (n :: Nat) (a :: AugType) = (r :: AugType) | r -> a where + Vectorisation n (Val a :--> b) = Val (FakeScalar n a) :--> Vectorisation n b + Vectorisation n (Val b) = Val b + +applyIdiomV + :: forall n as b + . ( KnownNat n, PrimTy b ) + => Idiom (V n) as (Val b) -> Maybe (Code (V n b)) +applyIdiomV idi = sanitiseVectorisation @n ( unsafeVectorise idi ) + +unsafeVectorise :: forall n as b. Idiom (V n) as b -> AST (Vectorisation n b) +unsafeVectorise (PureIdiom b) = unsafeCoerce b +unsafeVectorise (ApIdiom f (v :: Code (V n a))) + = fromAST + ( unsafeVectorise f ) + ( ( UnsafeCoerce :$ v ) :: AST (Val (FakeScalar n a)) ) + +class KnownNat n => SanitiseVectorisation (n :: Nat) (ast :: AugType -> Type) where + sanitiseVectorisationArgs :: PrimTy r => Application ast f (Val r) -> Maybe (Code (V n r)) + +sanitiseVectorisation + :: forall n r ast + . ( SanitiseVectorisation n ast, PrimTy r ) + => ast (Val r) -> Maybe (Code (V n r)) +sanitiseVectorisation r = sanitiseVectorisationArgs (Nullary r) + +instance ( KnownNat n, BottomUp (SanitiseVectorisation n) vs ) => SanitiseVectorisation n (VariantF vs) where + sanitiseVectorisationArgs (Applied f args) = + toBottomUp @(SanitiseVectorisation n) ( \x -> sanitiseVectorisationArgs $ Applied x args ) f + +deriving via VariantF ( ApplyAll (EGADT vs :: AugType -> Type) vs ) + instance ( KnownNat n, BottomUp (SanitiseVectorisation n) ( ApplyAll (EGADT vs) vs ) ) + => SanitiseVectorisation n (EGADT vs) + +instance SanitiseVectorisation n AST => SanitiseVectorisation n (AppF AST) where + sanitiseVectorisationArgs (Applied (AppF (Lam f) a) as) = sanitiseVectorisationArgs (Applied (f a) as) + sanitiseVectorisationArgs (Applied (AppF f a) as) = sanitiseVectorisationArgs (Applied f (a `ConsAST` as)) + +instance {-# OVERLAPPABLE #-} KnownNat n => SanitiseVectorisation n ast where + sanitiseVectorisationArgs = const Nothing + +instance KnownNat n => SanitiseVectorisation n (MkVectorF AST) where + sanitiseVectorisationArgs ( Applied (MkVectorF vec) NilAST ) + = Just ( unsafeCoerce $ MkVector vec ) + +instance KnownNat n => SanitiseVectorisation n (UnsafeCoerceF AST) where + sanitiseVectorisationArgs ( Applied UnsafeCoerceF (vec `ConsAST` NilAST) ) + = Just ( unsafeCoerce vec ) + +instance KnownNat n => SanitiseVectorisation n (LitF AST) where + sanitiseVectorisationArgs ( Applied (LitF a) NilAST ) + = Just ( Pure (Proxy @(V n)) (Lit ( unsafeCoerce a)) ) + +instance SanitiseVectorisation n AST => SanitiseVectorisation n (PrimOpF AST) where + sanitiseVectorisationArgs ( Applied (PrimOpF ( _ :: Proxy a ) ( _ :: Proxy op )) as ) + -- special case for 'vector times scalar' optimisation + | Just smul@SMul <- opSing @_ @_ @op @a + , ( _ :: SPrimOp a mul_op ) <- smul + , ( v1 `ConsAST` v2 `ConsAST` NilAST ) <- as + = case ( sanitiseVectorisation @n v1, sanitiseVectorisation @n v2 ) of + ( Just (Pure _ (b1 :: AST vb1)), Just (Pure _ (b2 :: AST vb2)) ) + | Refl <- ( unsafeCoerce Refl :: vb1 :~: Val (UnderlyingType vb1) ) + , Refl <- ( unsafeCoerce Refl :: vb2 :~: Val (UnderlyingType vb2) ) + , ( _ :: Proxy b1 ) <- Proxy @(UnderlyingType vb1) + , ( _ :: Proxy b2 ) <- Proxy @(UnderlyingType vb2) + -> let b1b2 :: Code a + b1b2 = unsafeCoerce b1 * unsafeCoerce b2 + b1b2' :: Code b1 + b1b2' = unsafeCoerce b1b2 + in Just $ Pure ( Proxy @(V n) ) b1b2' + ( Just (Pure _ b1), Just sv2 ) + -> let b1' :: Code a + b1' = unsafeCoerce b1 + sv2' :: Code (V n a) + sv2' = unsafeCoerce sv2 + in Just $ b1' *^ sv2' + ( Just sv1, Just (Pure _ b2) ) + -> let sv1' :: Code (V n a) + sv1' = unsafeCoerce sv1 + b2' :: Code a + b2' = unsafeCoerce b2 + in Just $ b2' *^ sv1' + ( Just sv1, Just sv2 ) + -> let + b1, b2 :: Code a + b1 = unsafeCoerce sv1 + b2 = unsafeCoerce sv2 + in applyvPrimOp + ( primOp @(V n a) @('Vectorise mul_op) ) + ( b1 `ConsAST` b2 `ConsAST` NilAST ) + _ -> Nothing + | Just ( VecPrimOpType ( _ :: Proxy v_a) ) <- vectorisation @_ @_ @op @a @n + , ( _ :: Proxy f ) <- Proxy @(PrimOpAugType op a) + , ( _ :: Proxy vf ) <- Proxy @(PrimOpAugType ('Vectorise op) v_a) + , Refl <- ( unsafeCoerce Refl :: FunRes f :~: Val (UnderlyingType (FunRes f)) ) + , Refl <- ( unsafeCoerce Refl :: ApplyFAug (V n) f :~: vf ) + = applyvPrimOp @n @f @(UnderlyingType (FunRes f)) ( primOp @v_a @('Vectorise op) ) as + | otherwise + = Nothing + +applyvPrimOp + :: forall (n :: Nat) f r + . ( KnownNat n, FunRes f ~ Val r, All PrimTyVal (FunArgs f) ) + => AST (ApplyFAug (V n) f) -> ASTs (FunArgs f) -> Maybe (Code (V n r)) +applyvPrimOp vPrimOp as = case allDict @PrimTyVal @(FunArgs f) of + NilDict + | Refl <- ( unsafeCoerce Refl :: f :~: Val (UnderlyingType f) ) + -> Just vPrimOp + ConsDict -> case as of + ( ( x :: AST (Val x) ) `ConsAST` xs ) + | Refl <- ( unsafeCoerce Refl :: f :~: ( Val x :--> SkipFirstArg f ) ) + , Just v <- sanitiseVectorisation @n x + -> applyvPrimOp ( vPrimOp :$ v ) xs + _ -> Nothing + +type family SkipFirstArg (x :: AugType) :: AugType where + SkipFirstArg (_ :--> b) = b diff --git a/src/CodeGen/Array.hs b/src/CodeGen/Array.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Array.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: CodeGen.Array + +This module defines the AST for a loop creating an array, to be processed by the code generator to define loops over arrays. + +This is done here with the user-facing syntax of the library, instead of wiring in the definition. +-} + +module CodeGen.Array + ( createArray ) + where + +-- base +import Data.Type.Equality + ( (:~:)(Refl) ) +import GHC.TypeLits + ( KnownSymbol ) +import GHC.TypeNats + ( KnownNat ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- fir +import Control.Monad.Indexed + ( pure, (>>), (>>=) ) +import Control.Type.Optic + ( Name, AnIndex, (:.:) ) +import Data.Type.Known + ( knownValue ) +import Data.Type.Map + ( (:->)((:->)) ) +import Math.Algebra.Class + ( AdditiveMonoid(fromInteger, (+)) ) +import Math.Logic.Class + ( Ord((<)) ) +import FIR.AST + ( AST, Code + , Syntactic(toAST) + , pattern Lit + ) +import FIR.AST.Type + ( Eff ) +import FIR.Binding + ( Var, RW ) +import FIR.Prelude +import FIR.Prim.Array + ( Array ) +import FIR.Prim.Types + ( PrimTy, HasOpaqueType ) +import FIR.ProgramState + ( ProgramState(ProgramState) ) +import FIR.Syntax.AST + ( ) +import FIR.Syntax.Program + ( def, get, put, assign + , locally, while + ) +import FIR.Validation.Bindings + ( Has, CanGet, CanPut + , ValidDef, AddBinding + ) + +---------------------------------------------------------------------------- + +-- | Code for a loop creating a new array. +-- +-- Assumes that the array has already been defined, +-- but allows it to be uninitialised. +-- +-- Runs in an environment with no local state. +createArray :: forall n arrName ixName a i j ctx cfg funs eps g_iface rayQs bkend. + ( KnownNat n + , KnownSymbol ixName + , KnownSymbol arrName + , PrimTy a + , i ~ 'ProgramState '[ arrName ':-> Var RW (Array n a) ] ctx cfg funs eps g_iface rayQs bkend + , j ~ AddBinding ixName (Var RW Word32) i + , Has ixName j ~ Word32 + , Has arrName j ~ Array n a + , CanGet ixName j + , CanPut ixName j + , CanGet arrName j + , CanPut arrName j + , ValidDef ixName i Word32 + ) + => ( Code Word32 -> Code a ) + -> AST ( Eff i i (Array n a) ) +createArray arrayFunction + | Refl <- ( unsafeCoerce Refl :: HasOpaqueType a :~: False ) -- bypass validity check + = toAST $ locally @i @j do + _ <- def @ixName @RW @Word32 @i 0 + while ( get @ixName < pure (Lit arrayLg) ) do + i <- get @ixName + assign @(Name arrName :.: AnIndex Word32) + i (arrayFunction i) + put @ixName (i+1) + get @arrName + where arrayLg :: Word32 + arrayLg = knownValue @n diff --git a/src/CodeGen/Atomics.hs b/src/CodeGen/Atomics.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Atomics.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +{-| +Module: CodeGen.Atomics + +Code generation for atomic operations. +-} + +module CodeGen.Atomics + ( atomicInstruction ) + where + +-- base +import Control.Monad + ( unless ) + +-- mtl +import Control.Monad.Except + ( throwError ) + +-- lens +import Control.Lens + ( view ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( pack ) + +-- fir +import CodeGen.Binary + ( instruction ) +import CodeGen.IDs + ( laidOutTypeID, constID ) +import CodeGen.Instruction + ( Args, toArgs + , ID(ID), Instruction(..) + , Pointer(..) + ) +import CodeGen.Monad + ( CGMonad + , MonadFresh(fresh) + ) +import CodeGen.Pointers + ( relayout ) +import CodeGen.State + ( _backend + , requireCapability, requireExtension + ) +import FIR.Prim.Atomic + ( SAtomicOp(..), atomicOp, SAtomicShape(..), atomicShape ) +import qualified SPIRV.Capability as SPIRV +import qualified SPIRV.Extension as SPIRV.Extension +import qualified SPIRV.Layout as SPIRV +import qualified SPIRV.Operation as SPIRV.Op +import qualified SPIRV.PrimTy as SPIRV +import qualified SPIRV.ScalarTy as SPIRV +import qualified SPIRV.Stage as SPIRV +import qualified SPIRV.Storage as Storage +import qualified SPIRV.Synchronisation as SPIRV + +---------------------------------------------------------------------------- + +-- | Perform an atomic operation on the scalar a pointer points to, +-- with the given operands. +atomicInstruction + :: SAtomicOp op -> Pointer -> [ ID ] -> CGMonad (ID, SPIRV.PrimTy) +atomicInstruction sOp (Pointer ptrID (SPIRV.PointerTy storage lay ty)) operandIDs + = do + bk <- view _backend + unless ( storage `elem` atomicStorageClasses bk ) $ + throwError + ( "codeGen: atomic operations are unsupported on pointers of storage " + <> "class " <> ShortText.pack ( show storage ) <> " for backend " + <> ShortText.pack ( show bk ) <> ".\n\ + \Supported storage classes: " + <> ShortText.pack ( show ( atomicStorageClasses bk ) ) <> "." + ) + op <- case ty of + SPIRV.Scalar sTy -> atomicOperation sOp sTy + _ -> throwError + ( "codeGen: " <> opName <> " is unsupported on values of type " + <> ShortText.pack ( show ty ) <> "." + ) + -- Device scope and relaxed memory semantics, as for GLSL atomics. + scopeID <- constID ( SPIRV.synchronisationScope SPIRV.Device ) + semanticsID <- constID ( SPIRV.memorySemanticsBitmask relaxed ) + laidOutOperands <- + traverse ( \ v -> relayout SPIRV.logical lay (v, ty) ) operandIDs + let + args :: Args + args = case ( atomicShape sOp, laidOutOperands ) of + -- A compare-exchange has separate memory semantics for success and + -- failure, and takes the new value before the expected value. + ( SCompares, [ expectedID, newID ] ) + -> toArgs + [ ptrID, scopeID, semanticsID, semanticsID, newID, expectedID ] + _ -> toArgs ( ptrID : scopeID : semanticsID : laidOutOperands ) + case atomicShape sOp of + SWrites -> do + instruction + Instruction + { operation = op + , resTy = Nothing + , resID = Nothing + , args + } + pure (ID 0, SPIRV.Unit) -- ID should never be used + _ -> do + tyID <- laidOutTypeID lay ty + v <- fresh + instruction + Instruction + { operation = op + , resTy = Just tyID + , resID = Just v + , args + } + (, ty) <$> relayout lay SPIRV.logical (v, ty) + where + opName :: ShortText + opName = ShortText.pack ( show ( atomicOp sOp ) ) + relaxed :: SPIRV.MemorySemantics + relaxed = SPIRV.MemorySemantics ( SPIRV.Lock [] ) [] + +-- | The SPIR-V instruction for an atomic operation on scalars of the given +-- type, requiring the capabilities and extensions it needs. +atomicOperation :: SAtomicOp op -> SPIRV.ScalarTy -> CGMonad SPIRV.Op.Operation +atomicOperation sOp sTy = case sTy of + SPIRV.Integer sgn w -> do + case w of + SPIRV.W32 -> pure () + SPIRV.W64 -> requireCapability SPIRV.Int64Atomics + _ -> unsupported + pure case sOp of + SAtomicLoad -> SPIRV.Op.AtomicLoad + SAtomicStore -> SPIRV.Op.AtomicStore + SAtomicExchange -> SPIRV.Op.AtomicExchange + SAtomicCompareExchange -> SPIRV.Op.AtomicCompareExchange + SAtomicIncrement -> SPIRV.Op.AtomicIIncrement + SAtomicDecrement -> SPIRV.Op.AtomicIDecrement + SAtomicAdd -> SPIRV.Op.AtomicIAdd + SAtomicSub -> SPIRV.Op.AtomicISub + SAtomicMin -> case sgn of + SPIRV.Signed -> SPIRV.Op.AtomicSMin + SPIRV.Unsigned -> SPIRV.Op.AtomicUMin + SAtomicMax -> case sgn of + SPIRV.Signed -> SPIRV.Op.AtomicSMax + SPIRV.Unsigned -> SPIRV.Op.AtomicUMax + SAtomicAnd -> SPIRV.Op.AtomicAnd + SAtomicOr -> SPIRV.Op.AtomicOr + SAtomicXor -> SPIRV.Op.AtomicXor + SPIRV.Floating w -> case sOp of + SAtomicLoad -> pure SPIRV.Op.AtomicLoad + SAtomicStore -> pure SPIRV.Op.AtomicStore + SAtomicExchange -> pure SPIRV.Op.AtomicExchange + SAtomicAdd -> do + case w of + SPIRV.W16 -> do + requireCapability SPIRV.AtomicFloat16AddEXT + requireExtension SPIRV.Extension.SPV_EXT_shader_atomic_float16_add + SPIRV.W32 -> do + requireCapability SPIRV.AtomicFloat32AddEXT + requireExtension SPIRV.Extension.SPV_EXT_shader_atomic_float_add + SPIRV.W64 -> do + requireCapability SPIRV.AtomicFloat64AddEXT + requireExtension SPIRV.Extension.SPV_EXT_shader_atomic_float_add + SPIRV.W8 -> unsupported + pure SPIRV.Op.AtomicFAddEXT + SAtomicMin -> SPIRV.Op.AtomicFMinEXT <$ floatMinMax + SAtomicMax -> SPIRV.Op.AtomicFMaxEXT <$ floatMinMax + _ -> unsupported + where + floatMinMax :: CGMonad () + floatMinMax = do + case w of + SPIRV.W16 -> requireCapability SPIRV.AtomicFloat16MinMaxEXT + SPIRV.W32 -> requireCapability SPIRV.AtomicFloat32MinMaxEXT + SPIRV.W64 -> requireCapability SPIRV.AtomicFloat64MinMaxEXT + SPIRV.W8 -> unsupported + requireExtension SPIRV.Extension.SPV_EXT_shader_atomic_float_min_max + where + unsupported :: CGMonad a + unsupported = throwError + ( "codeGen: " <> ShortText.pack ( show ( atomicOp sOp ) ) + <> " is unsupported on values of type " + <> ShortText.pack ( show sTy ) <> "." + ) + +-- | Storage classes of the pointers atomic operations accept, as specified by +-- the SPIR-V execution environment of each backend. +atomicStorageClasses :: SPIRV.Backend -> [ Storage.StorageClass ] +atomicStorageClasses SPIRV.Vulkan + = [ Storage.Uniform, Storage.Workgroup, Storage.Image, Storage.StorageBuffer ] +atomicStorageClasses SPIRV.OpenCL + = [ Storage.Function, Storage.Workgroup + , Storage.CrossWorkgroup, Storage.Generic + ] diff --git a/src/CodeGen/Binary.hs b/src/CodeGen/Binary.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Binary.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module: CodeGen.Binary + +Emitting SPIR-V binary data. +-} + +module CodeGen.Binary + ( putModule + , instruction + , structuralInstruction + , deferredInstructions + ) + where + +-- base +import Control.Monad + ( when ) +import Data.List + ( sortOn) +import Data.Foldable + ( traverse_) +import Data.Maybe + ( isJust ) +import Data.Word + ( Word32 ) +import qualified Data.Bits as Bits + +-- binary +import qualified Data.Binary as Binary +import qualified Data.Binary.Put as Binary + +-- containers +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map +import Data.Set + ( Set ) + +-- lens +import Control.Lens + ( view ) + +-- mtl +import Control.Monad.Except + ( ExceptT, throwError ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( pack ) + +-- transformers +import Control.Monad.Trans.Class + ( lift ) + +-- fir +import CodeGen.IDs + ( extInstID ) +import CodeGen.Instruction + ( Args(..), toArgs + , ID(..), TyID(..), pattern MkTyID + , Variable, variableID, variableDeclaration + , Instruction(..) + ) +import CodeGen.Monad + ( CGMonad, note, liftPut ) +import CodeGen.State + ( CGContext(..), CGState(moduleState), ModuleState(..) + , _emittingCode + , currentBlockID, leaveBlock + , currentFunctionContext + ) +import Data.Binary.Class.Put + ( Put(put, wordCount) ) +import Data.Containers.Traversals + ( traverseWithKey_, traverseSet_ ) +import FIR.ProgramState + ( FunctionContext(TopLevel) ) +import qualified SPIRV.Capability as SPIRV +import qualified SPIRV.Decoration as SPIRV +import qualified SPIRV.ExecutionMode as SPIRV +import qualified SPIRV.Extension as SPIRV + ( Extension, ExtInst, extInstName ) +import qualified SPIRV.Operation as SPIRV.Op +import qualified SPIRV.PrimTy as SPIRV +import qualified SPIRV.Stage as SPIRV +import qualified SPIRV.Version as SPIRV + +---------------------------------------------------------------------------- +-- emitting a SPIR-V module +-- some instruction need to be floated to the top + +putModule :: CGContext -> CGState -> ExceptT ShortText Binary.PutM () +putModule + CGContext { .. } + cgState + | emittingCode = do + lift $ do putHeader spirvVersion ( idNumber currentID ) + putCapabilities neededCapabilities + putExtensions neededExtensions + putExtendedInstructions knownExtInsts + putMemoryModel backend + let knownBindingIDs = map ( \ (name, (ident, _)) -> (name, ident) ) ( Map.toList knownBindings ) + usedGlobalIDs = map ( fmap variableID ) ( Map.toList usedGlobals ) + builtinIDs = map ( fmap variableID ) ( Map.elems builtinVariables ) + putEntryPoints entryPoints interfaces + putExecutionModes entryPoints userEntryPoints + lift $ do + putKnownStringLits knownStringLits + putBindingAnnotations knownBindingIDs + putBindingAnnotations usedGlobalIDs + putBindingAnnotations builtinIDs + putNames names + putDecorations decorations + putMemberDecorations memberDecorations + + -- Type and constant declarations need to be interleaved. + -- For instance, an array type needs to have + -- its length (a constant) defined earlier. + putTypesAndConstants knownTypes knownConstants + + putUndefineds knownUndefineds + + putGlobals + ( Map.elems usedGlobals + ++ map snd ( Map.elems builtinVariables ) + ) + | otherwise = pure () + where + ModuleState { .. } = moduleState cgState + +---------------------------------------------------------------------------- +-- individual binary instructions + +-- | Emit an instruction in the current block (if there is one). +-- +-- A block termination instruction ends the current block. +instruction :: Instruction -> CGMonad () +instruction inst = do + mbBlock <- currentBlockID + case mbBlock of + Nothing -> do + context <- currentFunctionContext + case context of + TopLevel -> + throwError ( "codeGen: instruction outside of a function: " <> ShortText.pack ( show ( operation inst ) ) ) + _ -> pure () + Just _ -> do + emitInstruction inst + when ( SPIRV.Op.isBlockTerminator ( operation inst ) ) + leaveBlock + +-- | Emit an instruction which doesn't belong to a block, such as a label or @OpFunction@. +structuralInstruction :: Instruction -> CGMonad () +structuralInstruction = emitInstruction + +-- | Emit instructions in the current block, without inspecting them during +-- code generation (for instructions that are only known after generating +-- subsequent code). +-- +-- Doesn't support extended instructions. +deferredInstructions :: [ Instruction ] -> CGMonad () +deferredInstructions insts = do + emitting <- view _emittingCode + mbBlock <- currentBlockID + when ( emitting && isJust mbBlock ) + ( liftPut ( traverse_ putInstruction insts ) ) + +emitInstruction :: Instruction -> CGMonad () +emitInstruction inst = do + emitting <- view _emittingCode + when emitting + case operation inst of + SPIRV.Op.ExtCode ext _ -> do + extID <- extInstID ext + liftPut $ putExtendedInstruction extID inst + _ -> liftPut $ putInstruction inst + +putInstruction :: Instruction -> Binary.Put +putInstruction Instruction { operation = op, resTy = opResTy, resID = opResID, args = opArgs } + = case op of + + SPIRV.Op.Code opCode -> + let n :: Word32 + n = 1 -- OpCode and word count (first byte) + + maybe 0 (const 1) opResTy -- result type (if present) + + maybe 0 (const 1) opResID -- ID (if present) + + wordCount opArgs + in do put @Word32 ( Bits.shift n 16 + fromIntegral opCode) + traverse_ put opResTy + traverse_ put opResID + put opArgs + + _ -> error "putInstruction: unexpected extended instruction" + +putExtendedInstruction :: ID -> Instruction -> Binary.Put +putExtendedInstruction extID Instruction { operation = op, resTy = opResTy, resID = opResID, args = opArgs } + = case op of + + SPIRV.Op.ExtCode _ extOpCode -> + putInstruction + Instruction + { operation = SPIRV.Op.ExtInst + , resTy = opResTy + , resID = opResID + , args = Arg extID + $ Arg extOpCode + opArgs + } + + _ -> error "putExtendedInstruction: unexpected non-extended instruction" + +putHeader :: SPIRV.Version -> Word32 -> Binary.Put +putHeader ver bound + = do + put SPIRV.magicNo + put ver + put libraryMagicNo + put bound + put ( 0 :: Word32 ) + where + libraryMagicNo :: Word32 + libraryMagicNo = 0x21524946 -- FIR! + +putCapabilities :: Set SPIRV.Capability -> Binary.Put +putCapabilities = traverseSet_ putCap + where + putCap :: SPIRV.Capability -> Binary.Put + putCap cap + = putInstruction + Instruction + { operation = SPIRV.Op.Capability + , resTy = Nothing + , resID = Nothing + , args = Arg cap + EndArgs + } + +putExtensions :: Set SPIRV.Extension -> Binary.Put +putExtensions = traverseSet_ putExt + where + putExt :: SPIRV.Extension -> Binary.Put + putExt ext + = putInstruction + Instruction + { operation = SPIRV.Op.Extension + , resTy = Nothing + , resID = Nothing + , args = Arg ext + EndArgs + } + +putExtendedInstructions :: Map SPIRV.ExtInst ID -> Binary.Put +putExtendedInstructions + = traverseWithKey_ \ extInst extID -> + putInstruction + Instruction + { operation = SPIRV.Op.ExtInstImport + , resTy = Nothing + , resID = Just extID + , args = Arg ( SPIRV.extInstName extInst ) EndArgs + } + +putMemoryModel :: SPIRV.Backend -> Binary.Put +putMemoryModel bk + = putInstruction + Instruction + { operation = SPIRV.Op.MemoryModel + , resTy = Nothing + , resID = Nothing + , args = Arg addressingModel + $ Arg memoryModel + EndArgs + } + where + addressingModel :: Word32 + addressingModel = case bk of + SPIRV.Vulkan -> 0 -- logical addressing + SPIRV.OpenCL -> 2 -- physical 64-bit addressing + memoryModel :: Word32 + memoryModel = case bk of + SPIRV.Vulkan -> 1 -- GLSL450 memory model + SPIRV.OpenCL -> 2 -- OpenCL memory model + +putEntryPoint :: SPIRV.ExecutionModel -> ShortText -> ID -> Map ShortText ID -> Binary.Put +putEntryPoint model modelName entryPointID interface + = putInstruction + Instruction + { operation = SPIRV.Op.EntryPoint + -- slight kludge to account for unusual parameters for OpEntryPoint + -- instead of result type, resTy field holds the ExecutionModel value + , resTy = Just . MkTyID $ SPIRV.executionModelID model + , resID = Just entryPointID + , args = Arg modelName + $ toArgs interface -- 'Map ShortText ID' has the appropriate traversable instance + } + +putEntryPoints + :: Map (ShortText, SPIRV.ExecutionModel) ID + -> Map (ShortText, SPIRV.ExecutionModel) (Map ShortText ID) + -> ExceptT ShortText Binary.PutM () +putEntryPoints entryPointIDs + = traverseWithKey_ + ( \(modelName, model) interface -> do + entryPointID + <- note + ( "putEntryPoints: " <> ShortText.pack (show model) + <> " entry point named \"" <> modelName + <> "\" not bound to any ID." + ) + ( Map.lookup (modelName, model) entryPointIDs ) + lift ( putEntryPoint model modelName entryPointID interface ) + ) + +putModelExecutionModes :: ID -> SPIRV.ExecutionModes -> Binary.Put +putModelExecutionModes modelID + = traverse_ + ( \case + SPIRV.MaxPatchVertices {} -> pure () -- custom execution mode that doesn't exist in SPIR-V + mode -> putInstruction + Instruction + { operation = SPIRV.Op.ExecutionMode + , resTy = Nothing + , resID = Nothing + , args = Arg modelID + $ Arg mode EndArgs + } + ) + +putExecutionModes + :: Map (ShortText, SPIRV.ExecutionModel) ID + -> Map (ShortText, SPIRV.ExecutionModel) SPIRV.ExecutionModes + -> ExceptT ShortText Binary.PutM () +putExecutionModes entryPointIDs + = traverseWithKey_ + ( \(modelName, model) executionModes -> do + entryPointID + <- note + ( "putExecutionModes: " <> ShortText.pack (show model) + <> " entry point named \"" <> modelName + <> "\" not bound to any ID." + ) + ( Map.lookup (modelName, model) entryPointIDs ) + lift ( putModelExecutionModes entryPointID executionModes ) + ) + +putKnownStringLits :: Map ShortText ID -> Binary.Put +putKnownStringLits + = traverseWithKey_ + ( \ lit ident -> putInstruction + Instruction + { operation = SPIRV.Op.String + , resTy = Nothing + , resID = Just ident + , args = Arg lit EndArgs + } + ) + +putBindingAnnotations :: [ ( ShortText, ID ) ] -> Binary.Put +putBindingAnnotations + = traverse_ + ( \ ( name, ident ) -> putInstruction + Instruction + { operation = SPIRV.Op.Name + , resTy = Nothing + , resID = Nothing + , args = Arg ident + $ Arg name EndArgs + } + ) + +putNames :: Set ( ID, Either ShortText (Word32, ShortText) ) -> Binary.Put +putNames = traverse_ + ( \case + ( ident, Left name ) + -> putInstruction + Instruction + { operation = SPIRV.Op.Name + , resTy = Nothing + , resID = Nothing + , args = Arg ident + $ Arg name EndArgs + } + + ( ident, Right (index,name) ) + -> putInstruction + Instruction + { operation = SPIRV.Op.MemberName + , resTy = Nothing + , resID = Nothing + , args = Arg ident + $ Arg index + $ Arg name EndArgs + } + ) + +putDecorations :: Map ID SPIRV.Decorations -> Binary.Put +putDecorations + = traverseWithKey_ + ( \ decoratee -> + traverse_ + ( \ dec -> + putInstruction + Instruction + { operation = SPIRV.Op.Decorate + , resTy = Nothing + , resID = Nothing + , args = Arg decoratee + $ Arg dec EndArgs + } + ) + ) + +putMemberDecorations :: Map (TyID, Word32) SPIRV.Decorations -> Binary.Put +putMemberDecorations + = traverseWithKey_ + ( \ (structTyID, index) -> + traverse_ + ( \dec -> + putInstruction + Instruction + { operation = SPIRV.Op.MemberDecorate + , resTy = Nothing + , resID = Nothing + , args = Arg structTyID + $ Arg index + $ Arg dec EndArgs + } + ) + ) + +putTypesAndConstants + :: Map types Instruction + -> Map constants Instruction + -> Binary.Put +putTypesAndConstants ts cs + = traverse_ putInstruction + ( sortOn resID $ Map.elems ts ++ Map.elems cs ) + +putUndefineds :: Map SPIRV.PrimTy (ID, TyID) -> Binary.Put +putUndefineds = traverse_ + ( \ ( undefID, undefTyID ) -> + putInstruction + Instruction + { operation = SPIRV.Op.Undef + , resTy = Just undefTyID + , resID = Just undefID + , args = EndArgs + } + ) + +putGlobals :: [ Variable ] -> Binary.Put +putGlobals = traverse_ ( putInstruction . variableDeclaration ) diff --git a/src/CodeGen/CFG.hs b/src/CodeGen/CFG.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/CFG.hs @@ -0,0 +1,691 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +{-| +Module: CodeGen.CFG + +Code generation for control flow operations: branching, selections, loops. + +See also "CodeGen.Phi" for ϕ-functions necessary for such constructs when using SSA form. +-} + +module CodeGen.CFG + ( newBlock, locally, embed ) + where + +-- base +import Prelude + hiding ( break ) +import Control.Arrow + ( second ) +import Control.Monad + ( unless, when ) +import Data.Foldable + ( for_ ) +import Data.Maybe + ( fromMaybe, isJust ) +import Data.Proxy + ( Proxy ) +import Data.Traversable + ( for ) +import Data.Word + ( Word32 ) + +-- containers +import Data.Map + ( Map ) +import qualified Data.Map.Strict as Map +import Data.Set + ( Set ) +import qualified Data.Set as Set + ( fromList, member, toList, isSubsetOf ) + +-- lens +import Control.Lens + ( view, use, assign ) + +-- mtl +import Control.Monad.Except + ( throwError ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( pack, unpack ) + +-- fir +import CodeGen.Application + ( ASTs(NilAST, ConsAST), UCode(UCode) + , Application(Applied) + ) +import CodeGen.Binary + ( instruction, structuralInstruction ) +import {-# SOURCE #-} CodeGen.CodeGen + ( CodeGen(codeGenArgs), codeGen ) +import CodeGen.Debug + ( whenAsserting ) +import CodeGen.IDs + ( typeID, constID ) +import CodeGen.Instruction + ( Args(Arg, EndArgs), toArgs + , ID(ID), Instruction(..) + , Pair(Pair) + ) +import CodeGen.Monad + ( MonadFresh(fresh) + , CGMonad + ) +import CodeGen.Phi + ( phiInstruction, phiInstructions ) +import CodeGen.State + ( LexicalEnv(localBindings) + , EarlyExit(..), LoopExit(..), LoopBlockIDs(..) + , _localBindings, _localBinding, _writableBindings + , _spirvVersion + , scoped + , withLoopFrame, inLoopBodyScope, innermostLoop, loopDepth, addLoopExit + , currentBlockID, enterBlock + ) +import Data.Containers.Traversals + ( traverseWithKey_ ) +import Data.Type.Known + ( knownValue ) +import Data.Type.Map + ( Keys ) +import FIR.AST + ( AST, Code + , SelectionF(..), LoopF(..), StateF(..) + , pattern (:$), pattern Return + ) +import FIR.AST.Type + ( AugType(Val), Eff, Nullary ) +import FIR.Prim.Types + ( IntegralTy, primTy ) +import FIR.ProgramState + ( Bindings ) +import qualified SPIRV.Control as SPIRV + ( SelectionControl, pattern NoSelectionControl + , LoopControl, pattern NoLoopControl + ) +import qualified SPIRV.Operation as SPIRV.Op +import qualified SPIRV.PrimTy as SPIRV + ( PrimTy(..) ) +import qualified SPIRV.Version as SPIRV + ( Version(..) ) + +---------------------------------------------------------------------------- +-- blocks and branching + +-- | Start a new block with the given ID. +block :: ID -> CGMonad () +block blockID = do + structuralInstruction + Instruction + { operation = SPIRV.Op.Label + , resTy = Nothing + , resID = Just blockID + , args = EndArgs + } + enterBlock blockID + +newBlock :: CGMonad () +newBlock = fresh >>= block + +-- | Whether the code currently being generated is reachable. +inReachableCode :: CGMonad Bool +inReachableCode = isJust <$> currentBlockID + +branch :: ID -> CGMonad () +branch branchID + = instruction + Instruction + { operation = SPIRV.Op.Branch + , resID = Nothing + , resTy = Nothing + , args = Arg branchID EndArgs + } + +branchConditional :: ID -> ID -> ID -> CGMonad () +branchConditional b t f + = instruction + Instruction + { operation = SPIRV.Op.BranchConditional + , resTy = Nothing + , resID = Nothing + , args = Arg b + $ Arg t + $ Arg f EndArgs + } + +unreachable :: CGMonad () +unreachable + = instruction + Instruction + { operation = SPIRV.Op.Unreachable + , resTy = Nothing + , resID = Nothing + , args = EndArgs + } + +select :: ID -> (ID, SPIRV.PrimTy) -> (ID, SPIRV.PrimTy) -> CGMonad (ID, SPIRV.PrimTy) +select c (o1, ty1) (o2, ty2) = do + ( whenAsserting . when (ty1 /= ty2) ) + ( throwError + ( "select: objects of different types: \n\ + \object 1: " <> ShortText.pack (show ty1) <> "\n\ + \object 2: " <> ShortText.pack (show ty2) <> "." + ) + ) + v <- fresh + resTyID <- typeID ty1 + instruction + Instruction + { operation = SPIRV.Op.Select + , resTy = Just resTyID + , resID = Just v + , args = Arg c + $ Arg o1 + $ Arg o2 + EndArgs + } + pure (v, ty1) + +selectionMerge :: ID -> Maybe SPIRV.SelectionControl -> CGMonad () +selectionMerge mergeBlockID mbControl + = instruction + Instruction + { operation = SPIRV.Op.SelectionMerge + , resTy = Nothing + , resID = Nothing + , args = Arg mergeBlockID + $ Arg mbControl + EndArgs + } +loopMerge :: ID -> ID -> SPIRV.LoopControl Word32 -> CGMonad () +loopMerge mergeBlockID loopBlockID loopControl + = instruction + Instruction + { operation = SPIRV.Op.LoopMerge + , resTy = Nothing + , resID = Nothing + , args = Arg mergeBlockID + $ Arg loopBlockID + $ Arg loopControl + EndArgs + } + +multiWaySwitch :: IntegralTy s => ID -> ID -> [Pair s ID] -> CGMonad () +multiWaySwitch scrut defBlock ids + = instruction + Instruction + { operation = SPIRV.Op.Switch + , resTy = Nothing + , resID = Nothing + , args = Arg scrut + $ Arg defBlock + $ toArgs ids + } + +-- | The values of the bindings (satisfying the predicate) at the start of a block, +-- given the bindings at the end of each of its predecessors. +-- Emits ϕ-instructions as necessary. +mergeBindings + :: ( ShortText -> Bool ) + -> [ ( ID, Map ShortText (ID, SPIRV.PrimTy) ) ] + -> CGMonad ( Map ShortText (ID, SPIRV.PrimTy) ) +mergeBindings isRelevant preds = case preds of + [] -> pure Map.empty + [ ( _, bds ) ] -> pure ( Map.filterWithKey ( \ name _ -> isRelevant name ) bds ) + _ -> do + phis <- phiInstructions isRelevant ( map fst preds ) ( map snd preds ) + let + common :: Map ShortText (ID, SPIRV.PrimTy) + common = Map.filterWithKey ( \ name _ -> isRelevant name ) + $ foldr1 Map.intersection ( map snd preds ) + pure ( Map.mapWithKey ( \ name ( ident, ty ) -> ( Map.findWithDefault ident name phis, ty ) ) common ) + +-- | Update the values of the given bindings. +updateBindings :: Map ShortText (ID, SPIRV.PrimTy) -> CGMonad () +updateBindings = traverseWithKey_ \ name bd -> assign ( _localBinding name ) ( Just bd ) + +---------------------------------------------------------------------------- +-- code generation for selections (pure or branching) + +instance CodeGen AST => CodeGen (SelectionF AST) where + + -- if statement + codeGenArgs (Applied IfF (c `ConsAST` (t :: Code a) `ConsAST ` f `ConsAST` NilAST)) = do + ver <- view _spirvVersion + if canUseSelection (primTy @a) ver + then selection c t f + else ifM c (UCode t) (UCode f) + where + canUseSelection :: SPIRV.PrimTy -> SPIRV.Version -> Bool + canUseSelection (SPIRV.Scalar _) _ = True + canUseSelection (SPIRV.Pointer _) _ = True + canUseSelection ty ver + | ver < SPIRV.Version 1 4 = False + | SPIRV.Matrix {} <- ty = True + | SPIRV.Vector {} <- ty = True + | SPIRV.Array {} <- ty = True + | SPIRV.Struct {} <- ty = True + | otherwise = False + + -- monadic if statement + codeGenArgs (Applied IfMF (c `ConsAST` t `ConsAST ` f `ConsAST` NilAST)) = ifM c (UCode t) (UCode f) + + -- switch statement + codeGenArgs (Applied (SwitchF scrut def cases) NilAST) = + codeGen + ( SwitchMF + ( Return :$ scrut ) + ( Return :$ def ) + ( map (second (Return :$)) cases ) + ) + + -- monadic switch statement + codeGenArgs (Applied (SwitchMF scrut def cases) NilAST) = switch scrut def (map (second UCode) cases) + + +selection :: ( CodeGen AST, Nullary a ) => Code Bool -> AST a -> AST a -> CGMonad (ID, SPIRV.PrimTy) +selection cond x y = do + (condID, condTy) <- codeGen cond + ( whenAsserting . unless ( condTy == SPIRV.Boolean) ) + ( throwError + $ "codeGen: ASSERT failed, 'select' expected boolean conditional, but got " + <> ShortText.pack (show condTy) + ) + o1 <- codeGen x + o2 <- codeGen y + select condID o1 o2 + +ifM :: ( CodeGen AST, Nullary b ) => AST b -> UCode -> UCode -> CGMonad (ID, SPIRV.PrimTy) +ifM cond bodyTrue bodyFalse + = branchingSelection conditionalHeader [bodyTrue, bodyFalse] + where + conditionalHeader :: [ID] -> ID -> CGMonad () + conditionalHeader [trueBlockID, falseBlockID] mergeBlockID = do + (condID, condTy) <- locally (codeGen cond) + ( whenAsserting . unless ( condTy == SPIRV.Boolean ) ) + ( throwError + $ "codeGen: ASSERT failed, 'if' expected boolean conditional, but got " + <> ShortText.pack (show condTy) + ) + selectionMerge mergeBlockID SPIRV.NoSelectionControl + branchConditional condID trueBlockID falseBlockID + conditionalHeader ids _ = + throwError + ( "codeGen: if statement with " + <> ShortText.pack ( show ( length ids )) + <> " branches" + ) + +switch :: ( CodeGen AST, IntegralTy t, Nullary s, Nullary a) + => AST s -> AST a -> [(t, UCode)] -> CGMonad (ID, SPIRV.PrimTy) +switch scrut def cases + = branchingSelection switchHeader (UCode def : map snd cases) + where + switchHeader :: [ID] -> ID -> CGMonad () + switchHeader [] _ = whenAsserting (throwError "codeGen: ASSERT failed, 'switch' statement missing default case") + switchHeader ( defaultBlockID : caseBlockIDs ) mergeBlockID = do + (scrutID, _) <- locally (codeGen scrut) + selectionMerge mergeBlockID SPIRV.NoSelectionControl + multiWaySwitch scrutID defaultBlockID + (zipWith ( \(t,_) i -> Pair (t,i) ) cases caseBlockIDs) + +branchingSelection :: CodeGen AST => ( [ID] -> ID -> CGMonad () ) -> [ UCode ] -> CGMonad (ID, SPIRV.PrimTy) +branchingSelection mkHeader cases = do + live <- inReachableCode + headerBlockID <- fresh + caseBlockIDs <- traverse (\x -> (,x) <$> fresh) cases + mergeBlockID <- fresh + bindingsBefore <- use _localBindings + + -- header block + when live do + branch headerBlockID + block headerBlockID + mkHeader ( map fst caseBlockIDs ) mergeBlockID + + -- code generation for each of the cases + results <- + for caseBlockIDs \ (caseBlockID, UCode caseBody) -> do + ( ( bodyRes, mbEndBlock ), env ) <- scoped do + when live ( block caseBlockID ) + bodyRes <- codeGen caseBody + mbEndBlock <- currentBlockID + branch mergeBlockID + pure ( bodyRes, mbEndBlock ) + pure ( bodyRes, ( , localBindings env ) <$> mbEndBlock ) + + ( firstRes, resType ) <- case results of + [] -> throwError "codeGen: empty list of branches in conditional" + ( ( firstRes@( _, ty ), _ ) : others ) + -> do ( whenAsserting . unless ( all ( ( == ty ) . snd . fst ) others ) ) + ( throwError "codeGen: ASSERT failed, branches of conditional return different types" ) + pure ( firstRes, ty ) + let + -- the cases which branch to the merge block + preds :: [ ( ID, ( (ID, SPIRV.PrimTy), Map ShortText (ID, SPIRV.PrimTy) ) ) ] + preds = [ ( endBlock, ( bodyRes, bds ) ) | ( bodyRes, Just ( endBlock, bds ) ) <- results ] + + if not live + then pure firstRes -- (unreachable code) + else do + -- merge block + block mergeBlockID + case preds of + [] -> do + -- No case reaches the merge block: the code that follows is unreachable. + unreachable + pure firstRes + _ -> do + -- emit the appropriate ϕ-instructions, and update the bindings + updateBindings + =<< mergeBindings ( `Map.member` bindingsBefore ) [ ( b, bds ) | ( b, ( _, bds ) ) <- preds ] + -- return the result + if resType == SPIRV.Unit + then pure (ID 0, resType) -- ID should never be used + else do + res <- fresh + phiInstruction + ( res, resType ) + [ Pair ( resID, b ) | ( b, ( ( resID, _ ), _ ) ) <- preds ] + pure (res, resType) + +---------------------------------------------------------------------------- +-- code generation for loops + +instance CodeGen AST => CodeGen (LoopF AST) where + codeGenArgs ( Applied WhileF ( c `ConsAST` body `ConsAST` NilAST ) ) = while ( Just c ) body + codeGenArgs ( Applied LoopF ( body `ConsAST` NilAST ) ) = while ( Nothing :: Maybe ( AST ( Val Bool ) ) ) body + codeGenArgs ( Applied ( BreakF ( _ :: Proxy n ) ) NilAST ) = break ( knownValue @n ) + codeGenArgs ( Applied ( BreakContinueF ( _ :: Proxy n ) ) NilAST ) = breakContinue ( knownValue @n ) + +-- | Code generation for a loop (with an optional condition in the loop header). +-- +-- Every modifiable binding gets a ϕ-instruction in the loop header. Its operand for the +-- back edge is only known after generating code for the loop body, which refers to the +-- ϕ-instruction: we tie the knot lazily. +while :: ( CodeGen AST, Nullary c, Nullary b ) => Maybe ( AST c ) -> AST b -> CGMonad (ID, SPIRV.PrimTy) +while mbCond loopBody = do + mbBefore <- currentBlockID + case mbBefore of + Nothing -> unreachableLoop + Just beforeBlockID -> reachableLoop beforeBlockID + pure (ID 0, SPIRV.Unit) -- ID should never be used + + where + + -- (generates code only to obtain the results; nothing is emitted) + unreachableLoop :: CGMonad () + unreachableLoop = do + loopIDs <- LoopBlockIDs <$> fresh <*> fresh + _ <- scoped $ withLoopFrame loopIDs do + for_ mbCond ( locally . codeGen ) + inLoopBodyScope ( codeGen loopBody ) + pure () + + reachableLoop :: ID -> CGMonad () + reachableLoop beforeBlockID = mdo + headerBlockID <- fresh + loopBlockID <- fresh + mergeBlockID <- fresh -- block where control flow merges back + continueBlockID <- fresh -- block at the end of the loop body from which we can continue for further loops + branch headerBlockID + + -- Header block. + block headerBlockID + bindingsBefore <- use _localBindings + writable <- use _writableBindings + let + -- Bindings that the loop might modify. + loopCarried :: Map ShortText (ID, SPIRV.PrimTy) + loopCarried = bindingsBefore `Map.restrictKeys` writable + + -- value of a binding at the end of the continue block (see below) + continueEndID :: ShortText -> ID + continueEndID name = + maybe + ( error $ "codeGen: binding " <> ShortText.unpack name <> " missing at the end of a loop" ) + fst + ( Map.lookup name continueEnd ) + headerPhis <- + Map.traverseWithKey + ( \ name ( beforeID, ty ) -> do + v <- fresh + -- NB: the second operand must not be forced during code generation. + phiInstruction ( v, ty ) + [ Pair ( beforeID , beforeBlockID ) + , Pair ( continueEndID name, continueBlockID ) + ] + pure ( v, ty ) + ) + loopCarried + updateBindings headerPhis + + loopMerge mergeBlockID continueBlockID SPIRV.NoLoopControl + -- The loop frame collects the early exits from the condition and the body. + ( ( headerEndBindings, mbHeaderEndBlockID, mbCondID, mbBodyEndBlock, bodyEndBindings ), loopExits ) <- + withLoopFrame ( LoopBlockIDs { continueBlockID, mergeBlockID } ) do + + -- Condition. + mbCondition <- case mbCond of + Nothing -> do + branch loopBlockID + pure Nothing + Just cond -> do + -- The condition gets its own block, as it might contain control flow. + condBlockID <- fresh + branch condBlockID + block condBlockID + (condID, condTy) <- locally (codeGen cond) + ( whenAsserting . when ( condTy /= SPIRV.Boolean ) ) + ( throwError + $ "codeGen: ASSERT failed, while loop expected boolean conditional, but got " + <> ShortText.pack (show condTy) + ) + pure ( Just condID ) + condEndBindings <- use _localBindings + mbCondEndBlock <- currentBlockID + for_ mbCondition \ condID -> branchConditional condID loopBlockID mergeBlockID + + -- Loop body. + ( mbEndBlock, env ) <- inLoopBodyScope $ scoped do + block loopBlockID + _ <- codeGen loopBody + mbEndBlock <- currentBlockID + branch continueBlockID + pure mbEndBlock + pure ( condEndBindings, mbCondEndBlock, mbCondition, mbEndBlock, localBindings env ) + + -- Continue block. + block continueBlockID + let + continuePreds :: [ ( ID, Map ShortText (ID, SPIRV.PrimTy) ) ] + continuePreds + = [ ( b, bodyEndBindings ) | Just b <- [ mbBodyEndBlock ] ] + ++ [ ( b, bds ) | ( b, ( ContinueLoop, bds ) ) <- Map.toList loopExits ] + for_ continuePreds \ ( _, bds ) -> + unless ( Map.keysSet loopCarried `Set.isSubsetOf` Map.keysSet bds ) $ + throwError "codeGen: early exit from a scope in which bindings modified by the loop are not visible" + continueEnd <- case continuePreds of + -- unreachable continue block: use the ϕ-instructions themselves + [] -> pure headerPhis + _ -> mergeBindings ( `Map.member` loopCarried ) continuePreds + branch headerBlockID + + -- Merge block (first block after the loop). + block mergeBlockID + let + -- with the early exit that remains to be performed (if any) + mergePreds :: [ ( ID, Maybe EarlyExit, Map ShortText (ID, SPIRV.PrimTy) ) ] + mergePreds + = [ ( b, Nothing, headerEndBindings ) | isJust mbCondID, Just b <- [ mbHeaderEndBlockID ] ] + ++ [ ( b, mbEarlyExit, bds ) | ( b, ( ExitLoop mbEarlyExit, bds ) ) <- Map.toList loopExits ] + case mergePreds of + -- Nothing exits the loop: the code that follows is unreachable. + [] -> unreachable + _ -> do + updateBindings + =<< mergeBindings ( `Map.member` bindingsBefore ) [ ( b, bds ) | ( b, _, bds ) <- mergePreds ] + continueEarlyExits [ ( b, mbEarlyExit ) | ( b, mbEarlyExit, _ ) <- mergePreds ] + +-- | Perform the remaining early exits from the merge block of a loop, +-- given the predecessors of the merge block and the early exit that remains for each. +-- +-- Emits ϕ-instructions: must be called at the start of the merge block. +continueEarlyExits :: [ ( ID, Maybe EarlyExit ) ] -> CGMonad () +continueEarlyExits preds = do + let + -- Selector value for each early exit to perform (0 for none). + selectors :: Map EarlyExit Word32 + selectors = Map.fromList $ zip ( Set.toList . Set.fromList $ [ ee | ( _, Just ee ) <- preds ] ) [ 1 .. ] + unless ( null selectors ) do + selectorID <- fresh + selectorValues <- + traverse + ( \ ( b, mbEarlyExit ) -> ( , b ) <$> constID ( maybe 0 ( selectors Map.! ) mbEarlyExit ) ) + preds + phiInstruction ( selectorID, primTy @Word32 ) ( map Pair selectorValues ) + caseBlockIDs <- traverse ( const fresh ) selectors + afterBlockID <- fresh + selectionMerge afterBlockID SPIRV.NoSelectionControl + multiWaySwitch selectorID afterBlockID + ( Map.elems $ Map.intersectionWith ( \ i caseBlockID -> Pair ( i, caseBlockID ) ) selectors caseBlockIDs ) + traverseWithKey_ ( \ ee caseBlockID -> block caseBlockID *> earlyExit ee ) caseBlockIDs + block afterBlockID + +-- | Break out of the given number of loops. +break :: Word32 -> CGMonad (ID, SPIRV.PrimTy) +break 0 = pure (ID 0, SPIRV.Unit) -- ID should never be used +break nbLoopsToBreak = do + depth <- loopDepth + when ( depth < fromIntegral nbLoopsToBreak ) $ + throwError + ( "codeGen: 'break' statement inside too few loops.\n\ + \breaking " <> ShortText.pack ( show nbLoopsToBreak ) <> " loops,\n\ + \but only inside " <> ShortText.pack ( show depth ) <> " loops." + ) + earlyExit ( Break nbLoopsToBreak ) + pure (ID 0, SPIRV.Unit) -- ID should never be used + +-- | Break out of the given number of loops, and then continue to the next iteration +-- of the enclosing loop. +breakContinue :: Word32 -> CGMonad (ID, SPIRV.PrimTy) +breakContinue nbLoopsToBreak = do + depth <- loopDepth + when ( depth <= fromIntegral nbLoopsToBreak ) $ + throwError + ( "codeGen: 'breakContinue' statement inside too few loops.\n\ + \continuing from start of loop after breaking " <> ShortText.pack ( show nbLoopsToBreak ) <> " loops,\n\ + \but only inside " <> ShortText.pack ( show depth ) <> " loops." + ) + earlyExit ( BreakContinue nbLoopsToBreak ) + pure (ID 0, SPIRV.Unit) -- ID should never be used + +-- | Perform an early exit. +-- +-- Structured control flow only allows branching to the continue or merge block of the +-- innermost loop: to exit several loops, we exit the innermost loop, and perform the +-- remaining early exit from its merge block. The same goes for an early exit from the +-- condition of a loop, which is lexically outside of the loop. +earlyExit :: EarlyExit -> CGMonad () +earlyExit ee = do + mbLoop <- innermostLoop + case mbLoop of + Nothing -> throwError "codeGen: early exit outside of a loop" + Just ( LoopBlockIDs { continueBlockID, mergeBlockID }, inBody ) -> do + let + ( loopExit, destBlockID ) = case ee of + _ | not inBody -> ( ExitLoop ( Just ee ) , mergeBlockID ) + BreakContinue 0 -> ( ContinueLoop , continueBlockID ) + BreakContinue n -> ( ExitLoop ( Just ( BreakContinue ( n - 1 ) ) ), mergeBlockID ) + Break n + | n <= 1 -> ( ExitLoop Nothing , mergeBlockID ) + | otherwise -> ( ExitLoop ( Just ( Break ( n - 1 ) ) ) , mergeBlockID ) + mbBlock <- currentBlockID + for_ mbBlock \ currentBlock -> do + currentBindings <- use _localBindings + addLoopExit currentBlock loopExit currentBindings + branch destBlockID + +---------------------------------------------------------------------------- +-- code-generation for locally / embed + +instance CodeGen AST => CodeGen (StateF AST) where + codeGenArgs (Applied LocallyF (a `ConsAST` NilAST)) = + locally (codeGen a) + codeGenArgs (Applied EmbedF ( ( a :: AST ( Eff i i a ) ) `ConsAST` NilAST)) = + embed ( Set.fromList $ knownValue @(Keys (Bindings i)) ) (codeGen a) + +locally :: CGMonad a -> CGMonad a +locally action = do + bindingsBefore <- use _localBindings + ( res, env ) <- scoped action + let + bindingsAfter :: Map ShortText (ID, SPIRV.PrimTy) + bindingsAfter = localBindings env + + -- keep the updated values of local bindings, + -- but only for bindings that were defined before the "locally" block + assign _localBindings ( bindingsAfter `Map.intersection` bindingsBefore ) + + whenAsserting do + let + weirdos :: Map ShortText ( (ID, SPIRV.PrimTy), (ID, SPIRV.PrimTy) ) + weirdos = Map.mapMaybe id + $ Map.intersectionWith ( \ ( id1, ty1 ) ( id2, ty2 ) -> if ty1 == ty2 then Nothing else Just ( ( id1, ty1 ), ( id2, ty2 ) ) ) + bindingsBefore bindingsAfter + unless ( null weirdos ) $ + throwError ( "'codeGen': ASSERT failed, error in code-generation for 'locally'\nweirdos = " <> ShortText.pack ( show weirdos ) ) + + pure res + +embed :: Set ShortText -> CGMonad a -> CGMonad a +embed innerStartNames action = do + bindingsBefore <- use _localBindings + ( res, env ) <- scoped do + assign _localBindings ( Map.restrictKeys bindingsBefore innerStartNames ) + action + let + bindingsAfter :: Map ShortText (ID, SPIRV.PrimTy) + bindingsAfter = localBindings env + + -- discard the updated values of local bindings that shadowed previous bindings + newBindings :: Map ShortText (ID, SPIRV.PrimTy) + newBindings = + Map.mapWithKey + ( \ name aft -> fromMaybe aft (shadows name innerStartNames bindingsBefore ) ) + ( bindingsAfter `Map.intersection` bindingsBefore + <> Map.withoutKeys bindingsBefore innerStartNames + ) + + assign _localBindings newBindings + pure res + +shadows :: ShortText -> Set ShortText -> Map ShortText (ID, SPIRV.PrimTy) -> Maybe (ID, SPIRV.PrimTy) +shadows name innerStartNames prevs + | not ( name `Set.member` innerStartNames ) + , Just prev <- Map.lookup name prevs + = Just prev + | otherwise + = Nothing diff --git a/src/CodeGen/CodeGen.hs b/src/CodeGen/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/CodeGen.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: CodeGen.CodeGen + +Main code generation function: dispatches code generation on the constructors of the AST. +-} + +module CodeGen.CodeGen + ( CodeGen(codeGenArgs), codeGen, runCodeGen ) + where + +-- base +import Prelude + hiding ( Monad(..) ) +import Data.Kind + ( Type ) +import Data.Proxy + ( Proxy ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import qualified GHC.Stack + ( callStack ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- bytestring +import Data.ByteString.Lazy + ( ByteString ) + +-- mtl +import Control.Monad.Except + ( throwError ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- variant +import Data.Variant.VariantF + ( VariantF, ApplyAll, BottomUp(toBottomUp) ) +import Data.Variant.EGADT + ( EGADT(..), HVariantF(..) ) + +-- fir +import CodeGen.Application + ( Application(Applied) + , pattern Nullary + , ASTs(NilAST, ConsAST) + ) +import CodeGen.Applicative + ( ) -- CodeGen instances for Ap, Pure +import CodeGen.Binary + ( putModule ) +import CodeGen.CFG + ( locally ) -- + CodeGen instances for If, IfM, Switch, SwitchM, While, Locally, Embed +import CodeGen.Composite + ( ) -- CodeGen instances for MkVector, Mat, UnMat, Struct, Array, GradedMappend +import CodeGen.Debug + ( whenDebugging, putSrcInfo ) -- CodeGen instance for DebugPrintF +import CodeGen.Functions + ( ) -- CodeGen instances for FunDef, FunCall, DefEntryPoint +import CodeGen.IDs + ( constID, undefID ) +import CodeGen.Images + ( ) -- CodeGen instances for image operands +import CodeGen.Instruction + ( ID, Pointer(..) ) +import CodeGen.Pointers + ( newVariable, store ) +import CodeGen.PrimOps + ( ) -- CodeGen instance for PrimOp +import CodeGen.RayTracing + ( ) -- Codegen instances for TraceRay, ExecuteCallable, RayQuery +import CodeGen.Monad + ( CGMonad, runCGMonad + , runExceptTPutM + ) +import CodeGen.Optics + ( ) -- CodeGen for View, Set, Use, Assign +import CodeGen.State + ( CGState, CGContext + , initialState + , currentFunctionContext + , defineLocalBinding + ) +import Data.Type.Known + ( knownValue ) +import FIR.AST + ( AST + , pattern (:$), pattern Lam, pattern MkID + , AppF(..), LamF(..), LitF(..), MkIDF(..), ValueF(..) + , IxMonadF(..) + , LetF(..), DefF(..), UnsafeCoerceF(..) + , HListF(..) + , UndefinedF(..) + ) +import FIR.AST.Type + ( AugType(Val, (:-->)), FunArgs, Nullary ) +import FIR.Binding + ( Permission(Write) ) +import FIR.Prim.Types + ( primTy ) +import FIR.ProgramState + ( FunctionContext(TopLevel) ) +import FIR.Syntax.AST + ( ) +import qualified SPIRV.PrimTy as SPIRV + +---------------------------------------------------------------------------- +-- run the code generator with given context to create a SPIR-V module + +runCodeGen :: Nullary a => CGContext -> AST a -> Either ShortText (ByteString, CGState) +runCodeGen context ast + = case runCGMonad context (initialState context) (codeGen ast) of + + Right (_, cgState, body) + -> case runExceptTPutM $ putModule context cgState of + Right ((), decs) -> Right ( decs <> body, cgState ) + Left err -> Left err + + Left err -> Left err + +---------------------------------------------------------------------------- +-- typeclass to dispatch code generation on AST constructors + +class CodeGen (ast :: AugType -> Type) where + codeGenArgs :: Nullary r => Application ast f r -> CGMonad (ID, SPIRV.PrimTy) + +codeGen :: ( CodeGen ast, Nullary v ) => ast v -> CGMonad (ID, SPIRV.PrimTy) +codeGen v = codeGenArgs (Nullary v) + +instance BottomUp CodeGen vs => CodeGen (VariantF vs) where + codeGenArgs (Applied f args) = + toBottomUp @CodeGen ( \x -> codeGenArgs $ Applied x args ) f + +deriving via VariantF ( ApplyAll (EGADT vs :: AugType -> Type) vs ) + instance BottomUp CodeGen ( ApplyAll (EGADT vs) vs ) + => CodeGen (EGADT vs) + +---------------------------------------------------------------------------- +-- some instances + +instance CodeGen AST => CodeGen (LamF AST) where + codeGenArgs (Applied (LamF f) (a `ConsAST` as)) = do + cg <- codeGen a + codeGenArgs ( Applied ( f (MkID cg) ) as ) + +instance CodeGen (LitF AST) where + codeGenArgs (Applied (LitF (a :: ty)) NilAST) = ( , primTy @ty ) <$> constID a + +instance CodeGen AST => CodeGen (MkIDF AST) where + codeGenArgs (Applied (MkIDF idTy) NilAST) = pure idTy + +-- TODO: "Value" should not be a constructor of the AST +-- we should internally change the AST to add the Value constructor when doing evaluation +instance CodeGen (ValueF AST) where + codeGenArgs _ = throwError "codeGen: unsupported embedded value" + +instance CodeGen AST => CodeGen (AppF AST) where + codeGenArgs (Applied (AppF (Lam f) a) as) = codeGenArgs (Applied (f a) as) + codeGenArgs (Applied (AppF f a) as) = codeGenArgs (Applied f (a `ConsAST` as)) + +instance CodeGen AST => CodeGen (IxMonadF AST) where + + codeGenArgs (Applied ReturnF (a `ConsAST` NilAST)) = codeGen a + + codeGenArgs (Applied BindF (a `ConsAST` f `ConsAST` as)) + | ( _ :: AST ( Val a :--> q j ) ) <- f + , Refl <- ( unsafeCoerce Refl :: FunArgs (q j) :~: '[] ) + = do + cg <- codeGen a + codeGenArgs ( Applied ( f :$ MkID cg ) as ) + +instance CodeGen AST => CodeGen (UnsafeCoerceF AST) where + codeGenArgs ( Applied UnsafeCoerceF (a `ConsAST` NilAST) ) = codeGenArgs ( Nullary a ) + +instance CodeGen AST => CodeGen (UndefinedF AST) where + codeGenArgs ( Applied undef@UndefinedF NilAST ) = case undef of + ( _ :: UndefinedF AST ( Val a ) ) -> + let undefTy = primTy @a + in ( , undefTy ) <$> undefID undefTy + +instance CodeGen AST => CodeGen (HListF AST) where + codeGenArgs _ = throwError "codeGen: internal error, cannot generate code for HList operations" + +instance CodeGen AST => CodeGen (LetF AST) where + codeGenArgs (Applied LetF (a `ConsAST` NilAST)) = locally (codeGen a) + +instance CodeGen AST => CodeGen (DefF AST) where + codeGenArgs (Applied (DefF (_ :: Proxy name) (_ :: Proxy ps)) (a `ConsAST` NilAST)) = do + let name = knownValue @name + writable = Write `elem` (knownValue @ps) + whenDebugging ( putSrcInfo GHC.Stack.callStack ) + cgRes@(a_ID, a_ty) <- codeGen a + + -- check if we should make this into a pointer or not + let + makeMutable = + case a_ty of + SPIRV.Array {} -> writable + SPIRV.RuntimeArray {} -> writable -- should never happen, user cannot define runtime arrays + SPIRV.Struct {} -> writable + _ -> False + + if makeMutable + then do + ctx <- currentFunctionContext + case ctx of + TopLevel -> + throwError ( "codeGen: cannot define mutable variable " <> name <> " at the top level" ) + _ -> pure () + ptr@( Pointer ptrID ptrTy ) <- newVariable a_ty + store name ptr a_ID + defineLocalBinding name (ptrID, SPIRV.Pointer ptrTy) False + else + defineLocalBinding name cgRes writable + pure cgRes diff --git a/src/CodeGen/CodeGen.hs-boot b/src/CodeGen/CodeGen.hs-boot new file mode 100644 --- /dev/null +++ b/src/CodeGen/CodeGen.hs-boot @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module CodeGen.CodeGen where + +-- base +import Data.Kind + ( Type ) + +-- fir +import CodeGen.Application + ( Application ) +import CodeGen.Instruction + ( ID ) +import CodeGen.Monad + ( CGMonad ) +import FIR.AST.Type + ( AugType, Nullary ) +import qualified SPIRV.PrimTy as SPIRV + +---------------------------------------------------------------------------- +-- export the 'CodeGen' type class and instance for the AST +-- this allows auxiliary code generation code to recursively call 'codeGen' + +class CodeGen (ast :: AugType -> Type) where + codeGenArgs :: Nullary r => Application ast f r -> CGMonad (ID, SPIRV.PrimTy) + +codeGen :: ( CodeGen f, Nullary a ) => f a -> CGMonad (ID, SPIRV.PrimTy) diff --git a/src/CodeGen/Composite.hs b/src/CodeGen/Composite.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Composite.hs @@ -0,0 +1,412 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module: CodeGen.Composite + +Code generation for composite objects (vectors, matrices, arrays and structures): construction and extraction. +-} + +module CodeGen.Composite + ( compositeConstruct + , compositeInsert, compositeExtract + , accessedTy, accessedLaidOutTy + , vectorShuffle, vectorSwizzle + , productConstruct + ) + where + +-- base +import Data.Foldable + ( toList ) +import Data.Proxy + ( Proxy ) +import Data.Word + ( Word32 ) +import GHC.TypeNats + ( natVal ) + +-- mtl +import Control.Monad.Except + ( throwError ) + +-- split +import Data.List.Split + ( chunksOf ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( pack ) + +-- vector-sized +import qualified Data.Vector.Sized as Vector + ( toList, knownLength' ) + +-- fir +import CodeGen.Application + ( Application(Applied) + , pattern Nullary + , ASTs(NilAST, ConsAST) + ) +import CodeGen.Binary + ( instruction ) +import {-# SOURCE #-} CodeGen.CodeGen + ( CodeGen(codeGenArgs), codeGen ) +import CodeGen.Debug + ( whenAsserting ) +import CodeGen.IDs + ( bindingID, typeID, undefID ) +import CodeGen.Instruction + ( Args(..), toArgs + , ID, Instruction(..) + ) +import CodeGen.Monad + ( CGMonad, MonadFresh(fresh), note ) +import Data.Type.Known + ( knownValue ) +import FIR.AST + ( AST + , MkVectorF(..), GradedMappendF(..) + , MatF(..) + , StructF(..), ArrayF(..), ArrayLengthF(..) + ) +import FIR.AST.Type + ( AugType(Val) ) +import FIR.Prim.Array + ( Array(MkArray) ) +import FIR.Prim.Struct + ( traverseStructASTs ) +import FIR.Prim.Types + ( primTy ) +import Math.Linear + ( V ) +import qualified SPIRV.Layout as SPIRV +import qualified SPIRV.Operation as SPIRV.Op +import qualified SPIRV.PrimTy as SPIRV +import SPIRV.PrimTy + ( PrimTy(..) ) +import qualified SPIRV.ScalarTy as SPIRV + ( ScalarTy(..), Signedness(..), Width(..) ) + +---------------------------------------------------------------------------- +-- Code generation for constructing composite objects. + +instance CodeGen AST => CodeGen (MkVectorF AST) where + codeGenArgs ( Applied (MkVectorF (vec :: V n (AST (Val a))) ) NilAST ) = do + let n = knownValue @n + compositeTy <- case primTy @a of + SPIRV.Scalar s -> + pure $ SPIRV.Vector n (SPIRV.Scalar s) + SPIRV.Vector m (SPIRV.Scalar s) -> + pure $ SPIRV.Matrix m n s + x -> + throwError + ( "codeGen: unexpected vector constituent " + <> ShortText.pack ( show x ) + ) + ( compositeConstruct compositeTy . map fst . toList ) + =<< traverse codeGen vec + +instance CodeGen AST => CodeGen (MatF AST) where + codeGenArgs ( Applied MatF (a `ConsAST` NilAST) ) = codeGenArgs ( Nullary a ) + codeGenArgs ( Applied UnMatF (a `ConsAST` NilAST) ) = codeGenArgs ( Nullary a ) + +instance CodeGen AST => CodeGen (StructF AST) where + codeGenArgs ( Applied structF@(StructF struct) NilAST ) = case structF of + ( _ :: StructF AST (Val struct) ) -> + compositeConstruct (primTy @struct) + =<< traverseStructASTs @AST (fmap fst . codeGen) struct + +instance CodeGen AST => CodeGen (ArrayF AST) where + codeGenArgs ( Applied arrF@(ArrayF (MkArray vec)) NilAST ) = case arrF of + ( _ :: ArrayF AST (Val (Array n a)) ) -> + let + n :: Word32 + n = Vector.knownLength' vec ( fromIntegral . natVal ) + arrTy :: SPIRV.PrimTy + arrTy = SPIRV.Array n ( primTy @a ) + in + compositeConstruct arrTy + =<< traverse (fmap fst . codeGen) (Vector.toList vec) + +instance CodeGen (ArrayLengthF AST) where + codeGenArgs ( Applied (ArrayLengthF (_ :: Proxy structName) (_ :: Proxy pos)) NilAST ) = do + let + structName :: ShortText + structName = knownValue @structName + arrayPos :: Word32 + arrayPos = knownValue @pos + (structBdID, _) <- bindingID structName + let + word32Ty :: SPIRV.PrimTy + word32Ty = SPIRV.Scalar ( SPIRV.Integer SPIRV.Unsigned SPIRV.W32 ) + word32TyID <- typeID word32Ty + v <- fresh + instruction + Instruction + { operation = SPIRV.Op.ArrayLength + , resTy = Just word32TyID + , resID = Just v + , args = Arg structBdID + $ Arg arrayPos + $ EndArgs + } + pure ( v, word32Ty ) + +instance CodeGen AST => CodeGen (GradedMappendF AST) where + codeGenArgs ( Applied GradedMappendF ( a `ConsAST` b `ConsAST` NilAST ) ) = do + (a_ID, a_ty) <- codeGen a + (b_ID, b_ty) <- codeGen b + case (a_ty, b_ty) of + ( SPIRV.Vector i (SPIRV.Scalar s), SPIRV.Vector j (SPIRV.Scalar t)) -> + if s /= t + then throwError "codeGen: graded semigroup operation on incompatible vectors" + else compositeConstruct (SPIRV.Vector (i+j) (SPIRV.Scalar s)) [a_ID, b_ID] + ( SPIRV.Matrix m n s, SPIRV.Matrix m' n' s' ) -> + if m /= m' || s /= s' + then throwError "codeGen: graded semigroup operation on incompatible matrices" + else do + cols1 <- traverse ( \i -> fst <$> compositeExtract (a_ID, a_ty) [i] ) [0..n -1] + cols2 <- traverse ( \i -> fst <$> compositeExtract (b_ID, b_ty) [i] ) [0..n'-1] + compositeConstruct (SPIRV.Matrix m (n+n') s) (cols1 ++ cols2) + ( SPIRV.Struct as, SPIRV.Struct bs ) -> + do + let lg = fromIntegral (length as) + lg' = fromIntegral (length bs) + elts1 <- traverse ( \i -> fst <$> compositeExtract (a_ID, a_ty) [i] ) [0..lg -1] + elts2 <- traverse ( \i -> fst <$> compositeExtract (b_ID, b_ty) [i] ) [0..lg'-1] + compositeConstruct + ( SPIRV.Struct (as ++ bs) ) + ( elts1 ++ elts2 ) + ( SPIRV.Array lg eltTy, SPIRV.Array lg' eltTy' ) -> + if eltTy /= eltTy' + then throwError "codeGen: graded semigroup operation on incompatible arrays" + else do + -- should probably use a loop instead of this, but nevermind + elts1 <- traverse ( \i -> fst <$> compositeExtract (a_ID, a_ty) [i] ) [0..lg -1] + elts2 <- traverse ( \i -> fst <$> compositeExtract (b_ID, b_ty) [i] ) [0..lg'-1] + compositeConstruct + ( SPIRV.Array (lg + lg') eltTy ) + ( elts1 ++ elts2 ) + _ -> throwError "codeGen: unsupported graded semigroup operation" + +---------------------------------------------------------------------------- +-- SPIR-V instructions. + +compositeConstruct :: SPIRV.PrimTy -> [ ID ] -> CGMonad (ID, SPIRV.PrimTy) +compositeConstruct compositeType constituents + = do tyID <- typeID compositeType + v <- fresh + instruction + Instruction + { operation = SPIRV.Op.CompositeConstruct + , resTy = Just tyID + , resID = Just v + , args = toArgs constituents + } + pure (v, compositeType) + +compositeExtract + :: (ID, SPIRV.PrimTy) + -> [ Word32 ] + -> CGMonad (ID, SPIRV.PrimTy) +compositeExtract (compositeID, compositeTy) indices + = do + constituentTy <- + note ( "'compositeExtract': could not compute accessee type.\n\ + \base: " <> ShortText.pack (show compositeTy) <> "\n\ + \indices: " <> ShortText.pack (show indices) <> "." + ) + ( accessedTy ( fmap Just indices ) compositeTy ) + constituentTyID <- typeID constituentTy + v <- fresh + instruction + Instruction + { operation = SPIRV.Op.CompositeExtract + , resTy = Just constituentTyID + , resID = Just v + , args = Arg compositeID + $ toArgs indices + } + pure (v, constituentTy) + +compositeInsert + :: (ID, SPIRV.PrimTy) + -> (ID, SPIRV.PrimTy) + -> [ Word32 ] + -> CGMonad (ID, SPIRV.PrimTy) +compositeInsert (inserteeID, inserteeTy) (compositeID, compositeTy) indices + = do + compositeTyID <- typeID compositeTy + constituentTy <- + note ( "'compositeInsert': could not compute constituent type.\n\ + \base: " <> ShortText.pack (show compositeTy) <> "\n\ + \indices: " <> ShortText.pack (show indices) <> "." + ) + ( accessedTy ( fmap Just indices ) compositeTy ) + constituentTyID <- typeID constituentTy + correctInserteeID <- + if constituentTy == inserteeTy + then pure inserteeID + else do + u <- fresh + instruction + Instruction + { operation = SPIRV.Op.BitCast + , resTy = Just constituentTyID + , resID = Just u + , args = Arg inserteeID EndArgs + } + pure u + v <- fresh + instruction + Instruction + { operation = SPIRV.Op.CompositeInsert + , resTy = Just compositeTyID + , resID = Just v + , args = Arg correctInserteeID + $ Arg compositeID + $ toArgs indices + } + pure (v, compositeTy) + + +-- | The type of the component at the given indices of a value of the given type. +accessedTy :: [ Maybe Word32 ] -> SPIRV.PrimTy -> Maybe SPIRV.PrimTy +accessedTy is ty = snd <$> accessedLaidOutTy is ( SPIRV.logical, ty ) + +-- | The type of the component at the given indices of a type with the given layout, +-- together with the layout of that component. +accessedLaidOutTy :: [ Maybe Word32 ] -> ( SPIRV.Layout, SPIRV.PrimTy ) -> Maybe ( SPIRV.Layout, SPIRV.PrimTy ) +accessedLaidOutTy [] base = Just base +accessedLaidOutTy (i : is) ( lay, baseTy ) = do + compTy <- componentTy i baseTy + accessedLaidOutTy is ( SPIRV.componentLayout baseTy lay, compTy ) + where + componentTy :: Maybe Word32 -> SPIRV.PrimTy -> Maybe SPIRV.PrimTy + componentTy _ (SPIRV.Vector {eltTy}) = Just eltTy + componentTy _ (SPIRV.Matrix {rows, entryTy}) = Just (SPIRV.Vector rows (SPIRV.Scalar entryTy)) + componentTy _ (SPIRV.Array {eltTy}) = Just eltTy + componentTy _ (SPIRV.RuntimeArray {eltTy}) = Just eltTy + componentTy (Just j) (SPIRV.Struct {eltTys}) + | j' < length eltTys = Just ( snd $ eltTys !! j' ) + where j' = fromIntegral j + componentTy _ _ + = Nothing + +---------------------------------------------------------------------------- +-- vector shuffle/swizzle + +vectorShuffle :: ( (ID, SPIRV.PrimTy), [Word32] ) + -> ( (ID, SPIRV.PrimTy), [Word32] ) + -> CGMonad (ID, SPIRV.PrimTy) +vectorShuffle ((u_ID, SPIRV.Vector n s), is) ((v_ID, SPIRV.Vector _ t), js) + | s /= t = throwError "vectorShuffle: incompatible vector components" + | otherwise = + do + v <- fresh + let indices = is ++ map (+n) js + shuffleTy = SPIRV.Vector ( fromIntegral (length is + length js) ) s + shuffleTyID <- typeID shuffleTy + instruction + Instruction + { operation = SPIRV.Op.VectorShuffle + , resTy = Just shuffleTyID + , resID = Just v + , args = Arg u_ID + $ Arg v_ID + $ toArgs indices + } + pure (v, shuffleTy) +vectorShuffle _ _ + = throwError "vectorShuffle used on non-vectors" + +vectorSwizzle :: (ID, SPIRV.PrimTy) -> [Word32] -> CGMonad (ID, SPIRV.PrimTy) +vectorSwizzle v@(_, vecTy) is = do + whenAsserting $ + case vecTy of + SPIRV.Vector {} -> pure () + _ -> throwError ( "vectorSwizzle: ASSERT failed, swizzle on non-vector: " <> ShortText.pack ( show v ) ) + case is of + [] -> throwError "vectorSwizzle: empty swizzle" + [i] -> compositeExtract v [i] + _ -> do + undef <- (,vecTy) <$> undefID vecTy + vectorShuffle (v, is) (undef, []) + -- using 'undefined' here prevents any code duplication that could result from + -- 'vectorShuffle (v, is) (v, [])' + -- (e.g. if 'v' is the result of an expensive computation, which could get inlined twice) + +---------------------------------------------------------------------------- +-- products + +-- like 'compositeConstruct', except it checks that the types are correct +-- (for matrices, it constructs the composite in two steps when needed) +productConstruct :: SPIRV.PrimTy -> [ ( ID, SPIRV.PrimTy ) ] -> CGMonad (ID, SPIRV.PrimTy) +productConstruct p as = case p of + SPIRV.Matrix {..} + | all ( (== SPIRV.Scalar entryTy) . snd ) as + && fromIntegral (length as) == rows * cols + -> do + columns <- traverse (compositeConstruct colTy . map fst) (chunksOf (fromIntegral rows) as) + compositeConstruct p (map fst columns) + | all ( (== colTy) . snd ) as + && fromIntegral (length as) == cols + -> compositeConstruct p (map fst as) + | otherwise + -> throwError $ + "'productConstruct': type mismatch for constructing matrix\n" + <> "attempting to construct matrix with " <> ShortText.pack (show rows) + <> " rows and " <> ShortText.pack (show cols) <> " columns of type " + <> ShortText.pack (show entryTy) <> ",\n" + <> "using components of types " <> ShortText.pack (show (map snd as)) + where + colTy :: SPIRV.PrimTy + colTy = SPIRV.Vector rows (SPIRV.Scalar entryTy) + SPIRV.Vector {..} + | all ( (== eltTy) . snd ) as + && fromIntegral (length as) == size + -> compositeConstruct p (map fst as) + | otherwise + -> throwError $ + "'productConstruct': type mismatch for constructing vector\n" + <> "attempting to construct vector with " <> ShortText.pack (show size) + <> " components of type " <> ShortText.pack (show eltTy) <> ",\n" + <> "using components of types " <> ShortText.pack (show (map snd as)) + SPIRV.Array {..} + | all ( (== eltTy) . snd ) as + && fromIntegral (length as) == size + -> compositeConstruct p (map fst as) + | otherwise + -> throwError $ + "'productConstruct': type mismatch for constructing array\n" + <> "attempting to construct array of size " <> ShortText.pack (show size) + <> " with elements of type " <> ShortText.pack (show eltTy) <> ",\n" + <> "using components of types " <> ShortText.pack (show (map snd as)) + SPIRV.Struct {..} + | and ( zipWith (\(_, ty1) (_,t2) -> ty1 == t2) eltTys as ) + && length as == length eltTys + -> compositeConstruct p (map fst as) + | otherwise + -> throwError $ + "'productConstruct': type mismatch for constructing structure\n" + <> "attempting to construct structure with elements of type " + <> ShortText.pack (show (map snd eltTys)) <> ",\n" + <> "using components of types " <> ShortText.pack (show (map snd as)) + otherTy + -> throwError $ + "'productConstruct': unexpected non-product type " + <> ShortText.pack ( show otherTy ) diff --git a/src/CodeGen/Debug.hs b/src/CodeGen/Debug.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Debug.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module: CodeGen.Debug + +Functionality for including extra debugging information as comments in SPIR-V modules, +such as including the line numbers of the Haskell source code. +-} + +module CodeGen.Debug + ( whenDebugging, whenAsserting + , putSrcInfo + ) + where + +-- base +import Control.Monad + ( when ) +import Data.Foldable + ( for_ ) +import Data.Word + ( Word32 ) +import qualified GHC.Stack +import qualified GHC.Stack.Types as GHC.Stack + +-- lens +import Control.Lens + ( view ) + +-- mtl +import Control.Monad.Reader + ( MonadReader ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( pack ) + +-- fir +import CodeGen.Application + ( Application(Applied) + , traverseASTs + ) +import CodeGen.Binary + ( instruction ) +import {-# SOURCE #-} CodeGen.CodeGen + ( CodeGen(codeGenArgs), codeGen ) +import CodeGen.IDs + ( stringLitID, typeID ) +import CodeGen.Instruction + ( ID(..), Args(..), toArgs + , Instruction(..) + ) +import CodeGen.Monad + ( MonadFresh(fresh), CGMonad, note ) +import CodeGen.State + ( CGContext + , _debugging + , _asserting + , requireExtension + , currentBlockID + ) +import FIR.AST + ( AST, DebugPrintfF(..) ) +import FIR.AST.Type + ( Nullary ) +import qualified SPIRV.Extension as SPIRV +import qualified SPIRV.Operation as SPIRV.Op +import qualified SPIRV.PrimTy as SPIRV + +---------------------------------------------------------------------------- +-- debug printf + +instance CodeGen AST => CodeGen (DebugPrintfF AST) where + codeGenArgs ( Applied ( DebugPrintfF formatString ) as ) = do + vals <- traverseASTs @Nullary ( fmap fst . codeGen ) as + debugPrintf formatString vals + +debugPrintf :: ShortText -> [ ID ] -> CGMonad (ID, SPIRV.PrimTy) +debugPrintf formatString vals = do + whenDebugging do + requireExtension SPIRV.SPV_KHR_non_semantic_info + unitTyID <- typeID SPIRV.Unit + v <- fresh + formatStringID <- stringLitID formatString + instruction + Instruction + { operation = SPIRV.Op.DebugPrintf + , resTy = Just unitTyID + , resID = Just v + , args = Arg formatStringID + $ toArgs vals + } + pure (ID 0, SPIRV.Unit) -- ID should not be used + +---------------------------------------------------------------------------- +-- debugging annotations + +whenDebugging :: MonadReader CGContext m => m () -> m () +whenDebugging action = (`when` action) =<< view _debugging + +whenAsserting :: MonadReader CGContext m => m () -> m () +whenAsserting action = (`when` action) =<< view _asserting + +sourceInfo :: GHC.Stack.CallStack -> Maybe (ShortText, Word32, Word32) +sourceInfo GHC.Stack.EmptyCallStack = Nothing +sourceInfo (GHC.Stack.PushCallStack _ loc stack) + = case sourceInfo stack of + Nothing + -> Just ( ShortText.pack $ GHC.Stack.srcLocFile loc + , fromIntegral $ GHC.Stack.srcLocStartLine loc + , fromIntegral $ GHC.Stack.srcLocStartCol loc + ) + Just info + -> Just info +sourceInfo (GHC.Stack.FreezeCallStack stack) = sourceInfo stack + +putSrcInfo :: GHC.Stack.CallStack -> CGMonad () +putSrcInfo callstack + = do + -- (no debug information outside of blocks) + mbBlock <- currentBlockID + for_ mbBlock \ _ -> do + (fileName, lineNo, colNo) + <- note "putSrcInfo: cannot find source location \ + \needed for debug statement" + ( sourceInfo callstack ) + fileID <- stringLitID fileName + instruction + Instruction + { operation = SPIRV.Op.Line + , resTy = Nothing + , resID = Nothing + , args = Arg fileID + $ Arg lineNo + $ Arg colNo EndArgs + } diff --git a/src/CodeGen/Functions.hs b/src/CodeGen/Functions.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Functions.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: CodeGen.Functions + +Code generation for function and entry-point definitions, and function calls. +-} + +module CodeGen.Functions ( ) where + +-- base +import Data.Foldable + ( traverse_ ) +import Data.Maybe + ( fromMaybe ) +import Data.Proxy + ( Proxy ) +import Data.Word + ( Word32 ) +import qualified GHC.Stack + ( callStack ) + +-- containers +import qualified Data.Map.Strict as Map + +-- lens +import Control.Lens + ( view, use, assign ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- fir +import CodeGen.Application + ( ASTs(NilAST, ConsAST) + , Application(Applied) + , traverseASTs + ) +import CodeGen.Binary + ( instruction, structuralInstruction, deferredInstructions ) +import {-# SOURCE #-} CodeGen.CodeGen + ( CodeGen(codeGenArgs), codeGen ) +import CodeGen.CFG + ( newBlock ) +import CodeGen.Debug + ( whenDebugging, putSrcInfo ) +import CodeGen.IDs + ( typeID ) +import CodeGen.Instruction + ( Args(..), toArgs + , ID, TyID + , Instruction(..) + , variableDeclaration + ) +import CodeGen.Monad + ( CGMonad + , MonadFresh(fresh) + , note + , createIDRec + ) +import CodeGen.State + ( FunctionState(localVariables) + , _knownBinding + , defineLocalBinding + , scoped + , withFunctionState + , _interface + , _entryPoint + , _userFunction + , requireCapabilities + ) +import Data.Type.Known + ( knownValue ) +import FIR.AST + ( AST + , FunDefF(..), FunCallF(..), DefEntryPointF(..) + ) +import FIR.AST.Type + ( Nullary ) +import FIR.Binding + ( Permission(Write), Permissions ) +import FIR.Prim.Types + ( primTy, knownVars ) +import FIR.ProgramState + ( FunctionContext(..) + , VLFunctionContext + , VLInterface + ) +import qualified SPIRV.Control as SPIRV + ( FunctionControl, pattern NoFunctionControl ) +import qualified SPIRV.Operation as SPIRV.Op +import qualified SPIRV.PrimTy as SPIRV + ( PrimTy(..) ) +import qualified SPIRV.Requirements as SPIRV + ( executionModelCapabilities ) +import qualified SPIRV.Stage as SPIRV + ( ExecutionModel, ExecutionInfo + , modelOf + ) + +---------------------------------- +-- code-generation for functions and entry points + +instance CodeGen AST => CodeGen (FunDefF AST) where + codeGenArgs (Applied (FunDefF (_ :: Proxy name) (_ :: Proxy as) (_ :: Proxy b)) (body `ConsAST` NilAST)) = + let as = knownVars @as + retTy = primTy @b + name = knownValue @name + in do + whenDebugging ( putSrcInfo GHC.Stack.callStack ) + control <- fromMaybe SPIRV.NoFunctionControl <$> view ( _userFunction name ) + funID <- declareFunction name control as retTy (codeGen body) + pure ( funID , SPIRV.Function (map (fst . snd) as) retTy ) + +instance CodeGen AST => CodeGen (FunCallF AST) where + codeGenArgs (Applied (FunCallF (_ :: Proxy name) ( _ :: Proxy as ) ( _ :: Proxy b )) (_ `ConsAST` as)) = do + let + funName = knownValue @name + retTy = primTy @b + retTyID <- typeID retTy + mbFunc <- use ( _knownBinding funName ) + func <- note + ( "codeGen: function " <> funName + <> "\" not bound to any ID." + ) + mbFunc + retID <- + declareFunctionCall + ( retTyID, retTy ) + func + =<< traverseASTs @Nullary codeGen as + pure ( retID, retTy ) + +instance CodeGen AST => CodeGen (DefEntryPointF AST) where + codeGenArgs (Applied (DefEntryPointF (_ :: Proxy name) (_ :: Proxy stageInfo)) (body `ConsAST` NilAST)) + = let name = knownValue @name + stageInfo = knownValue @stageInfo + in do + whenDebugging ( putSrcInfo GHC.Stack.callStack ) + entryPointID <- declareEntryPoint name stageInfo Nothing (codeGen body) -- TODO + pure ( entryPointID, SPIRV.Function [] SPIRV.Unit ) + +---------------------------------- +-- dealing with function context + +inFunctionContext :: ShortText -> [(ShortText, (SPIRV.PrimTy, Permissions))] -> CGMonad a -> CGMonad a +inFunctionContext functionName as + = inContext ( InFunction functionName as ) as + +inEntryPointContext + :: ShortText + -> SPIRV.ExecutionInfo Word32 model + -> Maybe VLInterface + -> CGMonad a + -> CGMonad a +inEntryPointContext modelName modelInfo mbIface + = inContext ( InEntryPoint modelName modelInfo mbIface ) [] + +inContext :: forall a. VLFunctionContext -> [(ShortText, (SPIRV.PrimTy, Permissions))] -> CGMonad a -> CGMonad a +inContext context as body = mdo + -- Use 'mdo' (and laziness) to declare local variables used in the function + -- body (discovered only after generating code for the function body). + ( ( a, _ ), funState ) <- + withFunctionState context $ scoped do + traverse_ (uncurry declareArgument) as + newBlock + deferredInstructions + ( map variableDeclaration ( Map.elems ( localVariables funState ) ) ) + body + pure a + +---------------------------------- +-- declaring function instructions + +declareFunctionCall :: (TyID, SPIRV.PrimTy) + -> (ID, SPIRV.PrimTy) + -> [ (ID, SPIRV.PrimTy) ] + -> CGMonad ID +declareFunctionCall res func argIDs + = do v <- fresh + instruction + Instruction + { operation = SPIRV.Op.FunctionCall + , resTy = Just (fst res) + , resID = Just v + , args = Arg (fst func) + $ toArgs (map fst argIDs) + } + pure v + +declareFunction :: ShortText + -> SPIRV.FunctionControl + -> [(ShortText, (SPIRV.PrimTy, Permissions))] + -> SPIRV.PrimTy + -> CGMonad (ID, SPIRV.PrimTy) + -> CGMonad ID +declareFunction funName control as b body + = createIDRec ( _knownBinding funName ) + ( do resTyID <- typeID b + fnTyID <- typeID funTy + pure (resTyID, fnTyID) + ) + ( \(resTyID,fnTyID) v -> do + structuralInstruction + Instruction + { operation = SPIRV.Op.Function + , resTy = Just resTyID + , resID = Just v + , args = Arg control + $ Arg fnTyID EndArgs + } + (retValID, _) <- inFunctionContext funName as body + case b of + SPIRV.Unit + -> instruction + Instruction + { operation = SPIRV.Op.Return + , resTy = Nothing + , resID = Nothing + , args = EndArgs + } + _ -> instruction + Instruction + { operation = SPIRV.Op.ReturnValue + , resTy = Nothing + , resID = Just retValID + , args = EndArgs + } + structuralInstruction + Instruction + { operation = SPIRV.Op.FunctionEnd + , resTy = Nothing + , resID = Nothing + , args = EndArgs + } + pure (v, funTy) + ) + where + funTy :: SPIRV.PrimTy + funTy = SPIRV.Function ( map (fst . snd) as ) b + + +declareArgument :: ShortText -> (SPIRV.PrimTy, Permissions) -> CGMonad ID +declareArgument argName (argTy, permissions) + = do + argTyID <- typeID argTy + v <- fresh + structuralInstruction + Instruction + { operation = SPIRV.Op.FunctionParameter + , resTy = Just argTyID + , resID = Just v + , args = EndArgs + } + let + writable = case argTy of + SPIRV.Pointer {} -> False + _ -> Write `elem` permissions + defineLocalBinding argName (v, argTy) writable + pure v + +declareEntryPoint + :: ShortText + -> SPIRV.ExecutionInfo Word32 model + -> Maybe VLInterface + -> CGMonad r + -> CGMonad ID +declareEntryPoint modelName modelInfo mbIface body + = createIDRec ( _knownBinding modelName ) + ( do unitTyID <- typeID SPIRV.Unit + fnTyID <- typeID funTy + pure (unitTyID, fnTyID) + ) + ( \(unitTyID,fnTyID) v -> do + -- declare entry point ID proper + assign ( _entryPoint modelName model ) (Just v) + -- initialise entry point with empty interface + -- (loading/storing should add to the interface as needed) + assign ( _interface modelName model ) (Just Map.empty) + -- set the required capabilities + requireCapabilities ( SPIRV.executionModelCapabilities model ) + + structuralInstruction + Instruction + { operation = SPIRV.Op.Function + , resTy = Just unitTyID + , resID = Just v + , args = Arg SPIRV.NoFunctionControl + $ Arg fnTyID EndArgs + } + _ <- inEntryPointContext modelName modelInfo mbIface body + instruction + Instruction + { operation = SPIRV.Op.Return + , resTy = Nothing + , resID = Nothing + , args = EndArgs + } + structuralInstruction + Instruction + { operation = SPIRV.Op.FunctionEnd + , resTy = Nothing + , resID = Nothing + , args = EndArgs + } + pure (v, funTy) + ) + where + model :: SPIRV.ExecutionModel + model = SPIRV.modelOf modelInfo + + funTy :: SPIRV.PrimTy + funTy = SPIRV.Function [] SPIRV.Unit diff --git a/src/CodeGen/IDs.hs b/src/CodeGen/IDs.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/IDs.hs @@ -0,0 +1,561 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module: CodeGen.IDs + +This module defines operations to obtain instruction IDs from the code generator state, such as: + + * 'typeID', which obtains the ID of a type, recursively defining new IDs for types that have not yet been defined, + * 'constID', which obtains the ID of a constant value. + +Suppose for instance we need an ID for the type @M 4 3 Float@, a matrix with 4 rows and 3 columns. +In SPIR-V, matrices are represented in column-major order, so the (informal) process to obtain an ID for this matrix is as follows: + + 1. query whether this matrix type has already been defined. If so, use that ID: we're done. Otherwise: + 2. query whether the column type @V 4 Float@ has already been defined. + If so, define a new ID with @OpTypeMatrix vec4FloatID 3@. Otherwise: + 3. query whether the entry type @Float@ has already been defined. + If so, define a column vector ID @OpTypeVector floatID 4@ and then a matrix ID from that as in 2. Otherwise: + 4. define a new ID for entry type, then one for the column type, then one for the matrix type. + +This process lends itself extremely well to a recursive traversal. + +-} + +module CodeGen.IDs + ( extInstID + , typeID, laidOutTypeID + , constID + , bindingID + , undefID + , builtinID + , globalID + , stringLitID + ) + where + +-- base +import Control.Monad + ( when ) +import Data.Coerce + ( coerce ) +import Data.Foldable + ( traverse_, for_ ) +import Data.Maybe + ( fromJust ) +import Data.Semigroup + ( First(First) ) +import Data.Word + ( Word32 ) + +-- containers +import qualified Data.Set as Set + +-- lens +import Control.Lens + ( Lens', view, use, assign ) + +-- mtl +import Control.Monad.Except + ( MonadError, throwError ) +import Control.Monad.State + ( MonadState ) +import Control.Monad.Reader + ( MonadReader ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- fir +import CodeGen.Instruction + ( ID(ID), TyID(TyID, tyID) + , Pointer(..), Variable(..) + , Instruction(..) + , Args(Arg, EndArgs), toArgs + ) +import CodeGen.Monad + ( MonadFresh + , createID, createIDRec + , tryToUse, tryToUseWith + , note + ) +import CodeGen.State + ( CGState, CGContext + , currentFunctionContext + , _knownExtInst + , _knownStringLit + , _knownBinding + , _localBinding + , _knownType + , _knownConstant + , _knownUndefined + , _builtin, _builtinVariable + , _usedGlobal + , _userGlobal + , _backend + , _interfaceBinding + , _spirvVersion + , requireCapabilities + , addName, addMemberName + , addDecoration, addDecorations + , addMemberDecoration, addMemberDecorations + ) +import FIR.Builtin + ( modelBuiltins, builtinCapabilities ) +import FIR.Layout + ( arrayStride, memberLayoutDecorations ) +import FIR.Prim.RayTracing + ( AccelerationStructure(..) ) +import FIR.Prim.Struct + ( traverseStruct ) +import FIR.Prim.Types + ( PrimTy(primTySing), primTy + , SPrimTy(..) + , aConstant + ) +import FIR.ProgramState + ( FunctionContext(InEntryPoint), executionContext ) +import Math.Linear + ( M(unM) ) +import qualified SPIRV.Builtin as SPIRV +import qualified SPIRV.Decoration as SPIRV +import qualified SPIRV.Extension as SPIRV + ( ExtInst ) +import qualified SPIRV.Image as SPIRV.Image +import qualified SPIRV.Layout as SPIRV +import qualified SPIRV.Operation as SPIRV.Op +import qualified SPIRV.PrimTy as SPIRV +import qualified SPIRV.PrimTy as SPIRV.PrimTy +import qualified SPIRV.Requirements as SPIRV + ( primTyCapabilities ) +import qualified SPIRV.ScalarTy as SPIRV +import qualified SPIRV.Stage as SPIRV +import qualified SPIRV.Storage as Storage +import qualified SPIRV.Version as SPIRV + +---------------------------------------------------------------------------- +-- instructions generated along the way that need to be floated to the top + +-- get extended instruction set ID (or create one if none exist) +extInstID :: (MonadState CGState m, MonadFresh ID m) + => SPIRV.ExtInst -> m ID +extInstID extInst = + tryToUse ( _knownExtInst extInst ) + id + pure + +-- | Get the ID of a (logical) type. +typeID :: ( MonadReader CGContext m + , MonadState CGState m + , MonadFresh ID m + , MonadError ShortText m + ) + => SPIRV.PrimTy -> m TyID +typeID = laidOutTypeID SPIRV.logical + +-- | Get the ID of a type with the given layout +-- (the result ID of the corresponding type constructor instruction). +-- +-- If the type has not yet been declared, this recursively declares it, +-- together with the types it depends on. +laidOutTypeID :: forall m. + ( MonadReader CGContext m + , MonadState CGState m + , MonadFresh ID m + , MonadError ShortText m + ) + => SPIRV.Layout -> SPIRV.PrimTy -> m TyID +laidOutTypeID lay ty = TyID <$> + tryToUseWith _knownPrimTy + ( coerce . fromJust . resID ) -- type constructor instructions always have a result ID + do requireCapabilities ( SPIRV.primTyCapabilities ty ) + bk <- view _backend + case ty of + + SPIRV.Matrix m n a -> + createIDRec _knownPrimTy + ( tyID <$> typeID (SPIRV.Vector m (SPIRV.Scalar a)) ) -- column type + ( \ colID + -> mkTyConInstruction ( Arg colID $ Arg n EndArgs ) + ) + + SPIRV.Vector n a -> + createIDRec _knownPrimTy + ( tyID <$> typeID a ) -- element type + ( \ eltID + -> mkTyConInstruction ( Arg eltID $ Arg n EndArgs ) + ) + + SPIRV.Function as b -> + createIDRec _knownPrimTy + ( do asIDs <- traverse typeID as -- types of function arguments + bID <- typeID b -- return type of function + pure (asIDs, bID) + ) + ( \ (asIDs, bID) + -> mkTyConInstruction ( Arg bID $ toArgs asIDs ) + ) + + SPIRV.Array l a -> + createIDRec _knownPrimTy + ( do lgID <- constID l -- array size is the result of a constant instruction + eltID <- laidOutTypeID componentLayout a -- as opposed to being a literal number + pure (eltID, lgID) -- (I suppose this is to do with specialisation constants) + ) + ( \(eltTyID, lgID) v -> do + addArrayStride v a + mkTyConInstruction ( Arg eltTyID $ Arg lgID EndArgs ) v + ) + + SPIRV.RuntimeArray a -> + createIDRec _knownPrimTy + ( laidOutTypeID componentLayout a ) + ( \eltTyID v -> do + addArrayStride v a + mkTyConInstruction ( Arg eltTyID EndArgs ) v + ) + + SPIRV.Unit -> createID _knownPrimTy ( mkTyConInstruction EndArgs ) + SPIRV.Boolean -> createID _knownPrimTy ( mkTyConInstruction EndArgs ) + SPIRV.AccelerationStructure -> createID _knownPrimTy ( mkTyConInstruction EndArgs ) + SPIRV.RayQuery -> createID _knownPrimTy ( mkTyConInstruction EndArgs ) + + SPIRV.Scalar (SPIRV.Integer s w) + | SPIRV.Signed <- s + , SPIRV.OpenCL <- bk + -> tyID <$> typeID ( SPIRV.Scalar (SPIRV.Integer SPIRV.Unsigned w) ) -- no "sign semantics" in OpenCL + + SPIRV.Scalar (SPIRV.Integer s w) + -> createID _knownPrimTy + ( mkTyConInstruction + ( Arg (SPIRV.width w) $ Arg (SPIRV.signedness s) EndArgs ) + ) + + SPIRV.Scalar (SPIRV.Floating w) + -> createID _knownPrimTy + ( mkTyConInstruction ( Arg (SPIRV.width w) EndArgs ) ) + + SPIRV.Struct as + -> createIDRec _knownPrimTy + ( traverse ( fmap tyID . laidOutTypeID componentLayout . snd ) as ) -- return IDs of struct member types + ( \eltIDs structTyID -> + do + memberLayoutDecs <- + case SPIRV.layoutRules lay of + Just rules -> memberLayoutDecorations rules ( map snd as ) + Nothing -> pure ( map ( const Set.empty ) as ) + + -- add information: name of each struct field, and decorations + for_ ( zip3 [0..] as memberLayoutDecs ) + ( \ (i, (mbFieldName, _), eltDecs) -> do + traverse_ ( addMemberName (TyID structTyID) i ) mbFieldName + addMemberDecorations (TyID structTyID) i eltDecs + -- the members of a block of built-in variables are decorated using their names + when ( SPIRV.blockKind lay == Just SPIRV.BuiltinBlock ) $ + for_ ( SPIRV.readBuiltin =<< mbFieldName ) + ( addMemberDecoration (TyID structTyID) i . SPIRV.Builtin ) + ) + + -- decorate interface blocks + for_ ( SPIRV.blockKind lay ) \ kind -> do + addDecoration structTyID SPIRV.Block + when ( kind == SPIRV.BuiltinBlock ) $ + addName structTyID "gl_PerVertex" + + -- declare the type + mkTyConInstruction (toArgs eltIDs) structTyID + ) + + SPIRV.Pointer (SPIRV.PointerTy storage pointeeLayout a) -> + createIDRec _knownPrimTy + ( laidOutTypeID pointeeLayout a ) + ( \ tyID -> mkTyConInstruction ( Arg storage $ Arg tyID EndArgs ) ) + + SPIRV.PrimTy.Image (SPIRV.Image.Image { .. }) + -> createIDRec _knownPrimTy + ( typeID (SPIRV.Scalar texelComponent) ) -- get the type ID of the image 'component' type + ( \componentID + -> mkTyConInstruction + ( Arg componentID + $ Arg dimensionality + $ Arg hasDepth + $ Arg arrayness + $ Arg multiSampling + $ Arg imageUsage + $ Arg imageFormat + EndArgs + ) + ) + + SPIRV.Sampler -> createID _knownPrimTy ( mkTyConInstruction EndArgs ) + + SPIRV.SampledImage imageTy + -> createIDRec _knownPrimTy + ( typeID (SPIRV.PrimTy.Image imageTy) ) + ( \ imgTyID -> mkTyConInstruction (Arg imgTyID EndArgs ) ) + + where _knownPrimTy :: Lens' CGState (Maybe Instruction) + _knownPrimTy = _knownType declarationLayout ty + + -- Layout only affects the declarations of arrays and structures. + declarationLayout :: SPIRV.Layout + declarationLayout = case ty of + SPIRV.Array {} -> lay + SPIRV.RuntimeArray {} -> lay + SPIRV.Struct {} -> lay + _ -> SPIRV.logical + + componentLayout :: SPIRV.Layout + componentLayout = SPIRV.componentLayout ty lay + + -- Arrays in explicitly laid out memory have a stride, + -- except for arrays of interface blocks. + addArrayStride :: ID -> SPIRV.PrimTy -> m () + addArrayStride v eltTy = case lay of + SPIRV.Layout { SPIRV.layoutRules = Just rules, SPIRV.blockKind = Nothing } + -> addDecoration v . SPIRV.ArrayStride =<< arrayStride rules eltTy + _ -> pure () + + mkTyConInstruction :: Args -> ID -> m Instruction + mkTyConInstruction flds v + = pure + Instruction + { operation = SPIRV.tyOp ty + , resTy = Nothing + , resID = Just v + , args = flds + } + +-- get the ID for a given constant, or create one if none exist +-- this is the crucial location where we make use of singletons to perform type-case +constID :: forall m a. + ( MonadReader CGContext m + , MonadState CGState m + , MonadFresh ID m + , MonadError ShortText m + , PrimTy a + ) + => a -> m ID +constID a = + tryToUseWith _knownAConstant + ( fromJust . resID ) -- constant definition instructions always have a result ID + do resTyID <- typeID (primTy @a) -- start off by getting an ID for the type! + let mkConstantInstruction + :: SPIRV.Op.Operation -> Args -> ID -> m Instruction + mkConstantInstruction op flds v + = pure + Instruction + { operation = op + , resTy = Just resTyID + , resID = Just v + , args = flds + } + case primTySing @a of + + SMatrix {} -> + createIDRec _knownAConstant + ( traverse constID . unM $ a ) -- get the ID for each column + ( \ cols -> + mkConstantInstruction + SPIRV.Op.ConstantComposite + ( toArgs cols ) + ) + + SVector {} -> + createIDRec _knownAConstant + ( traverse constID a ) -- get the result ID for each component + ( \ eltIDs -> + mkConstantInstruction + SPIRV.Op.ConstantComposite + (toArgs eltIDs) + ) + + SScalar {} + -> createID _knownAConstant + ( mkConstantInstruction + SPIRV.Op.Constant + ( Arg a EndArgs ) + ) + + SUnit + -> pure (ID 0) -- should not be used + {- create _knownAConstant + ( mkConstantInstruction + SPIRV.Op.ConstantNull + EndArgs + ) + -} + {- + throwError + "constId: called on Unit type.\n\ + \Unit has a unique value, \ + \and as such does not need to be constructed." + -} + + SBool -> + createID _knownAConstant + ( mkConstantInstruction + ( if a + then SPIRV.Op.ConstantTrue + else SPIRV.Op.ConstantFalse + ) + EndArgs + ) + + SRuntimeArray {} -> + throwError + "'constID': cannot construct run-time arrays.\n\ + \Runtime arrays are only available through entry-point interfaces." + + SAccelerationStructure {} -> + createIDRec _knownAConstant + ( constID ( case a of { AccelerationStructureFromWord64 handle -> handle } ) ) + ( \ handleID -> + mkConstantInstruction + SPIRV.Op.ConvertUToAccelerationStructure + ( Arg handleID EndArgs ) + ) + + SArray {} -> + createIDRec _knownAConstant + ( traverse constID a ) + ( \ eltIDs -> + mkConstantInstruction + SPIRV.Op.ConstantComposite + ( toArgs eltIDs ) + ) + + SStruct {} -> + createIDRec _knownAConstant + ( traverseStruct constID a :: m [ID] ) + ( \ eltIDs -> + mkConstantInstruction + SPIRV.Op.ConstantComposite + ( toArgs eltIDs ) + ) + + where _knownAConstant :: Lens' CGState (Maybe Instruction) + _knownAConstant = _knownConstant ( aConstant a ) + + +-- left-biased semigroup operation +infixl 6 < +(<) :: forall x. Maybe x -> Maybe x -> Maybe x +(<) = coerce ( (<>) @(Maybe (First x)) ) + +bindingID :: forall m. + ( MonadState CGState m + , MonadReader CGContext m + , MonadError ShortText m + , MonadFresh ID m + ) => ShortText -> m (ID, SPIRV.PrimTy) +bindingID varName + = do ctxt <- currentFunctionContext + bk <- view _backend + case ctxt of + InEntryPoint modelName modelInfo _ + | Just ptrTy <- lookup varName (modelBuiltins modelInfo) + -> + do -- this is a built-in variable, use 'builtinID' + builtin <- builtinID modelName modelInfo varName ptrTy + -- requirement + let requirements = builtinCapabilities bk varName + requireCapabilities requirements + -- note that 'builtinID' sets the necessary decorations for the builtin + pure (builtin, SPIRV.Pointer ptrTy) + _ -> + do -- this is not a built-in variable, obtain the binding ID + mbLoc <- use ( _localBinding varName ) + mbKnown <- use ( _knownBinding varName ) + mbGlob <- + fmap ( \ ( Pointer v ptrTy ) -> ( v, SPIRV.Pointer ptrTy ) ) + <$> globalID varName (executionContext ctxt) + + -- return the binding ID (throwing an error if none was found) + note + ( "codeGen: no binding with name " <> varName ) + ( mbLoc < mbKnown < mbGlob ) + +undefID :: ( MonadReader CGContext m + , MonadState CGState m + , MonadError ShortText m + , MonadFresh ID m + ) + => SPIRV.PrimTy -> m ID +undefID ty = + tryToUse ( _knownUndefined ty ) + fst + ( \v -> do + tyID <- typeID ty + pure (v,tyID) + ) + +-- | Get the ID for a built-in variable. +-- +-- Automatically switches on this built-in in the interface of the relevant entry-point, +-- by using the '_builtin' lens. +builtinID :: ( MonadReader CGContext m + , MonadState CGState m + , MonadError ShortText m + , MonadFresh ID m + ) + => ShortText -> SPIRV.ExecutionInfo Word32 model -> ShortText -> SPIRV.PointerTy -> m ID +builtinID modelName modelInfo builtinName ptrTy = + tryToUse ( _builtin modelName modelInfo builtinName ) + id + ( \ v -> do + ptrTyID <- typeID ( SPIRV.Pointer ptrTy ) + assign ( _builtinVariable v ) ( Just ( builtinName, Variable ( Pointer v ptrTy ) ptrTyID ) ) + pure v + ) + +-- | Get the ID for a user-defined global variable, +-- adding this global to the list of 'used' global variables if it isn't already there, +-- adding the required decorations, and (manually) adding this global variable +-- to the relevant stage interface if necessary. +globalID :: ( MonadState CGState m + , MonadReader CGContext m + , MonadError ShortText m + , MonadFresh ID m + ) + => ShortText -> Maybe (ShortText, SPIRV.ExecutionModel) -> m ( Maybe Pointer ) +globalID globalName mbModel + = do ver <- view _spirvVersion + mbGlobID <- view ( _userGlobal globalName ) + case mbGlobID of + Nothing + -> pure Nothing + Just (ptrTy, decs) + -> do + ptr@( Pointer ident _ ) <- + tryToUse ( _usedGlobal globalName ) + variablePointer + ( \ v -> do + addDecorations v decs + ptrTyID <- typeID ( SPIRV.Pointer ptrTy ) + pure ( Variable ( Pointer v ptrTy ) ptrTyID ) + ) + case (mbModel, ptrTy) of + ( Just (model, modelName), SPIRV.PointerTy storage _ _ ) + | ver >= SPIRV.Version 1 4 + || storage == Storage.Input + || storage == Storage.Output + -> assign ( _interfaceBinding model modelName globalName ) ( Just ident ) + _ -> pure () + pure ( Just ptr ) + +stringLitID :: (MonadState CGState m, MonadFresh ID m) + => ShortText -> m ID +stringLitID literal = + tryToUse ( _knownStringLit literal ) + id + pure diff --git a/src/CodeGen/Images.hs b/src/CodeGen/Images.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Images.hs @@ -0,0 +1,566 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module: CodeGen.Images + +Code generation for image sampling, reading and writing. +-} + +module CodeGen.Images + ( imageTexel, writeTexel ) + where + +-- base +import Control.Arrow + ( first, (&&&) ) +import Data.Bits + ( Bits((.|.), shiftR, testBit) ) +import Data.List + ( insertBy ) +import Data.Ord + ( comparing ) +import Data.Proxy + ( Proxy ) +import Data.Word + ( Word32 ) + +-- lens +import Control.Lens + ( view ) + +-- mtl +import Control.Monad.Except + ( throwError ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( pack ) + +-- fir +import CodeGen.Application + ( ASTs(..), Application(..) ) +import CodeGen.Binary + ( instruction ) +import CodeGen.Composite + ( vectorSwizzle ) +import {-# SOURCE #-} CodeGen.CodeGen + ( CodeGen(codeGenArgs), codeGen ) +import CodeGen.IDs + ( bindingID, constID, typeID ) +import CodeGen.Instruction + ( ID, TyID, Instruction(..), Pointer(..) + , Args(Arg,EndArgs), toArgs + ) +import CodeGen.Monad + ( CGMonad, MonadFresh(fresh) ) +import CodeGen.Pointers + ( load ) +import CodeGen.State + ( _backend, requireCapability, requireCapabilities ) +import Data.Type.Known + ( Known, knownValue ) +import FIR.AST + ( AST, Code + , pattern NilOps, pattern Proj, pattern Dref, pattern Bias + , pattern LOD, pattern MinLOD, pattern Grad + , pattern ConstOffsetBy, pattern OffsetBy + , pattern Gather, pattern SampleNo + , ImgOpsF + ) +import FIR.AST.Images + ( ImgQueryF(..) ) +import FIR.Prim.Image + ( ImageProperties, ImageAndCoordinate(..) + , ImageCoordinateKind(..) + , ImageOperands, OperandName + , GatherInfo(..) + , knownImage + ) +import FIR.Prim.Types + ( primTy ) +import SPIRV.Image + ( DepthTesting(..), Projection(..) ) +import qualified SPIRV.Capability as SPIRV + ( pattern ComputeKernel, pattern ImageQuery ) +import qualified SPIRV.Image as SPIRV + hiding ( Image(Image) ) +import qualified SPIRV.Image + ( Image(Image) ) +import qualified SPIRV.Operation as SPIRV + ( Operation ) +import qualified SPIRV.Operation as SPIRV.Op +import qualified SPIRV.PrimTy as SPIRV +import qualified SPIRV.PrimTy + ( PrimTy(Image, SampledImage) ) +import qualified SPIRV.Requirements as SPIRV + ( lodCapabilities + , gatherCapabilities + , unknownFormatReadCapabilities + , unknownFormatWriteCapabilities + ) +import qualified SPIRV.Stage as SPIRV + ( Backend(OpenCL, Vulkan) ) + +-------------------------------------------------------------------------- +-- image sample/read/write + +imageTexel + :: forall + ( props :: ImageProperties ) + ( ops :: [OperandName] ) + . ( CodeGen AST, Known ImageProperties props ) + => (ID, SPIRV.PrimTy) + -> Code (ImageOperands props ops) + -> ID + -> (TyID, SPIRV.PrimTy) + -> CGMonad (ID, SPIRV.PrimTy) +imageTexel (imgID, imgTy) ops coords (imgTexelTyID, imgTexelTy) + = do + ( bm, operandsArgs ) <- operandsToArgs ops + let lod = lodMethod bm + proj = projection bm + dtest = depthTesting bm + gathering = gather bm + ImageAndCoordinate + ( SPIRV.Image.Image + { SPIRV.dimensionality = dim + , SPIRV.imageFormat = mbFmt + } + , coordCompKind + ) = knownValue @props + + v <- fresh + let + -- Image reads, (non-depth-comparison) sampling and gathering return + -- four components: narrow the result to the requested texel type. + texelInstruction :: Bool -> SPIRV.Operation -> Args -> CGMonad (ID, SPIRV.PrimTy) + texelInstruction fourComponents op texelArgs = case imgTexelTy of + SPIRV.Scalar s + | fourComponents + -> narrow ( SPIRV.Vector 4 ( SPIRV.Scalar s ) ) [0] + SPIRV.Vector n c + | fourComponents, n < 4 + -> narrow ( SPIRV.Vector 4 c ) [ 0 .. n - 1 ] + _ -> do + instruction ( Instruction { operation = op, resTy = Just imgTexelTyID, resID = Just v, args = texelArgs } ) + pure ( v, imgTexelTy ) + where + narrow vec4Ty components = do + vec4TyID <- typeID vec4Ty + instruction ( Instruction { operation = op, resTy = Just vec4TyID, resID = Just v, args = texelArgs } ) + vectorSwizzle ( v, vec4Ty ) components + + res <- case coordCompKind of + -- must be using a sampler (accessing with floating-point coordinates) + FloatingPointCoordinates + -> do sampledImgID + <- case imgTy of + SPIRV.PrimTy.SampledImage _ + -> pure imgID + SPIRV.PrimTy.Image _ + -> throwError + ( "codeGen: cannot sample image with floating-point coordinates: \ + \no sampler provided." + ) + _ -> throwError + ( "codeGen: image sampling operation provided non-image \ + \of type " <> ShortText.pack ( show imgTy ) + ) + if gathering + then texelInstruction True ( gatherOperation dtest ) + ( Arg sampledImgID $ Arg coords $ operandsArgs ) + else texelInstruction ( dtest == NoDepthTest ) ( sampleOperation lod dtest proj ) + ( Arg sampledImgID $ Arg coords $ operandsArgs ) + -- reading from image directly (using integral coordinates) + IntegralCoordinates + -> do plainImgID + <- case imgTy of + SPIRV.PrimTy.Image _ + -> pure imgID + SPIRV.PrimTy.SampledImage plainImg + -> fst <$> removeSampler (imgID, plainImg) + _ -> throwError + ( "codeGen: image read operation provided non-image \ + \of type " <> ShortText.pack ( show imgTy ) + ) + res <- texelInstruction True SPIRV.Op.ImageRead + ( Arg plainImgID $ Arg coords $ operandsArgs ) + requireCapabilities ( SPIRV.unknownFormatReadCapabilities dim mbFmt ) + pure res + + -- declare capabilities + requireOperandCapabilities bm + + pure res + + +writeTexel + :: forall props ops + . ( CodeGen AST, Known ImageProperties props ) + => (ID, SPIRV.PrimTy) + -> Code (ImageOperands props ops) + -> ID + -> ID + -> CGMonad () +writeTexel (imgID, imgTy) ops coords texel + = do + let SPIRV.Image.Image + { SPIRV.imageFormat = mbFmt + } = knownImage @props + + ( bm, operandsArgs ) <- operandsToArgs ops + plainImgID + <- case imgTy of + SPIRV.PrimTy.Image _ + -> pure imgID + SPIRV.PrimTy.SampledImage plainImg + -> fst <$> removeSampler (imgID, plainImg) + _ -> throwError + ( "codeGen: image write operation provided non-image \ + \of type " <> ShortText.pack ( show imgTy ) + ) + instruction + Instruction + { operation = SPIRV.Op.ImageWrite + , resTy = Nothing + , resID = Nothing + , args = Arg plainImgID + $ Arg coords + $ Arg texel + $ operandsArgs + } + + -- declare capabilities + requireOperandCapabilities bm + requireCapabilities ( SPIRV.unknownFormatWriteCapabilities mbFmt ) + + -- return the result ID + pure () + +-------------------------------------------------------------------------- +-- add/remove sampler + +{- +addSampler :: (ID, SPIRV.Image.Image) -> ID -> CGMonad (ID, SPIRV.PrimTy) +addSampler (imgID, imgTy) samplerID + = do + let sampledImgTy = SPIRV.PrimTy.SampledImage imgTy + sampledImgTyID <- typeID sampledImgTy + v <- fresh + instruction + Instruction + { operation = SPIRV.Op.SampledImage + , resTy = Just sampledImgTyID + , resID = Just v + , args = Arg imgID + $ Arg samplerID EndArgs + } + pure (v, sampledImgTy) +-} + +removeSampler :: CodeGen AST => (ID, SPIRV.Image.Image) -> CGMonad (ID, SPIRV.PrimTy) +removeSampler (imgID, imgTy) + = do + let plainImgTy = SPIRV.PrimTy.Image imgTy + plainImgTyID <- typeID plainImgTy + v <- fresh + instruction + Instruction + { operation = SPIRV.Op.Image + , resTy = Just plainImgTyID + , resID = Just v + , args = Arg imgID EndArgs + } + pure (v, plainImgTy) + +-------------------------------------------------------------------------- +-- sampling: find which sampling operation to use + +data LODMethod + = ImplicitLOD + | ExplicitLOD + deriving stock ( Show, Eq, Ord, Enum, Bounded ) + +lodMethod :: Word32 -> LODMethod +lodMethod bm + | bm `testBit` 9 || bm `testBit` 10 = ExplicitLOD --'LOD' or 'Grad' operand provided + | otherwise = ImplicitLOD + +depthTesting :: Word32 -> DepthTesting +depthTesting bm + | bm `testBit` 0 = DepthTest + | otherwise = NoDepthTest + +projection :: Word32 -> Projection +projection bm + | bm `testBit` 1 = Projective + | otherwise = Affine + +gather :: Word32 -> Bool +gather = (`testBit` 13) + +sampleOperation :: LODMethod -> DepthTesting -> Projection -> SPIRV.Operation +sampleOperation ImplicitLOD NoDepthTest Affine = SPIRV.Op.ImageSampleImplicitLod +sampleOperation ExplicitLOD NoDepthTest Affine = SPIRV.Op.ImageSampleExplicitLod +sampleOperation ImplicitLOD DepthTest Affine = SPIRV.Op.ImageSampleDrefImplicitLod +sampleOperation ExplicitLOD DepthTest Affine = SPIRV.Op.ImageSampleDrefExplicitLod +sampleOperation ImplicitLOD NoDepthTest Projective = SPIRV.Op.ImageSampleProjImplicitLod +sampleOperation ExplicitLOD NoDepthTest Projective = SPIRV.Op.ImageSampleProjExplicitLod +sampleOperation ImplicitLOD DepthTest Projective = SPIRV.Op.ImageSampleProjDrefImplicitLod +sampleOperation ExplicitLOD DepthTest Projective = SPIRV.Op.ImageSampleProjDrefExplicitLod + +gatherOperation :: DepthTesting -> SPIRV.Operation +gatherOperation NoDepthTest = SPIRV.Op.ImageGather +gatherOperation DepthTest = SPIRV.Op.ImageDrefGather + +-------------------------------------------------------------------------- +-- capabilities + +-- | Declare the capabilities required by the image operands +-- given by the bitmask. +requireOperandCapabilities :: Word32 -> CGMonad () +requireOperandCapabilities bm + = do + bk <- view _backend + requireCapabilities ( SPIRV.lodCapabilities bk bm ) + requireCapabilities ( SPIRV.gatherCapabilities bm ) + +-------------------------------------------------------------------------- +-- dealing with operands + +instance CodeGen (ImgOpsF ast) where + codeGenArgs _ = throwError "Unexpected image operand." + +operands :: CodeGen AST => Code (ImageOperands props ops) -> CGMonad (Word32, [(ID, Word32)]) +operands NilOps = pure ( 0x0000, [] ) +operands (Proj ops) = first ( 0x0002 .|. ) <$> operands ops +operands (Dref dref ops) + = do + i <- fst <$> codeGen dref + (bm, nxt) <- operands ops + let opBit = 0x0001 + pure ( opBit .|. bm + , insertBy (comparing snd) (i, opBit) nxt + ) +operands (Bias bias ops) + = do + i <- fst <$> codeGen bias + (bm, nxt) <- operands ops + let opBit = 0x0100 + pure ( opBit .|. bm + , insertBy (comparing snd) (i, opBit) nxt + ) +operands (LOD lod ops) + = do + i <- fst <$> codeGen lod + (bm, nxt) <- operands ops + let opBit = 0x0200 + pure ( opBit .|. bm + , insertBy (comparing snd) (i, opBit) nxt + ) +operands (Grad (gx,gy) ops) + = do + i1 <- fst <$> codeGen gx + i2 <- fst <$> codeGen gy + (bm, nxt) <- operands ops + let opBit = 0x0400 + pure ( opBit .|. bm + , stableSplice ([i1,i2], opBit) nxt ) +operands (ConstOffsetBy off ops) + = do + i <- constID off + (bm, nxt) <- operands ops + let opBit = 0x0800 + pure ( opBit .|. bm + , insertBy (comparing snd) (i, opBit) nxt + ) +operands (OffsetBy off ops) + = do + offID <- fst <$> codeGen off + (bm, nxt) <- operands ops + let opBit = 0x1000 + pure ( opBit .|. bm + , insertBy (comparing snd) (offID, opBit) nxt + ) +operands (Gather (ComponentWithOffsets comp offs) ops) + = do + compID <- fst <$> codeGen comp + offsID <- constID offs + (bm, nxt) <- operands ops + let opBit = 0x2000 + pure ( opBit .|. bm + , insertBy (comparing snd) (compID, 0x0001) -- says "put me first", see 'opArgs' + . insertBy (comparing snd) (offsID, opBit ) + $ nxt + ) +operands (Gather (DepthWithOffsets offs) ops) + = do + offsID <- constID offs + (bm, nxt) <- operands ops + let opBit = 0x2000 + pure ( opBit .|. bm + , insertBy (comparing snd) (offsID, opBit) nxt + ) +operands (SampleNo no ops) + = do + i <- fst <$> codeGen no + (bm, nxt) <- operands ops + let opBit = 0x4000 + pure ( opBit .|. bm + , insertBy (comparing snd) (i, opBit) nxt + ) +operands (MinLOD lod ops) + = do + i <- fst <$> codeGen lod + (bm, nxt) <- operands ops + let opBit = 0x8000 + pure ( opBit .|. bm + , insertBy (comparing snd) (i, opBit) nxt + ) +operands ops + = throwError + $ "'operands': image operands not of the expected form\n" + <> ShortText.pack (show ops) + +opArgs :: Word32 -> [(ID, Word32)] -> Args +opArgs _ [] = EndArgs +opArgs bm ((putMeFirst, 0x0001) : ops) + -- special case for an argument that needs to be put first + -- must go before everything else (including bitmask) + = Arg putMeFirst (opArgs bm ops) +opArgs bm ops + = Arg + ( shiftR bm 8 ) -- bitmask first, with bottom byte removed + ( toArgs (map fst ops) ) -- then the IDs in order + +operandsToArgs :: CodeGen AST => Code (ImageOperands props ops) -> CGMonad (Word32, Args) +operandsToArgs ops = (fst &&& uncurry opArgs) <$> operands ops + +stableSplice :: Ord b => ( [a], b ) -> [ (a,b) ] -> [ (a,b) ] +stableSplice ( as, bref ) [] + = map ( , bref ) as +stableSplice l1@( as, bref ) l2@( (a, b) : nxt ) + | b > bref = map ( , bref ) as ++ l2 + | otherwise = ( a, b ) : stableSplice l1 nxt + +-------------------------------------------------------------------------- +-- image query operations + +instance CodeGen AST => CodeGen (ImgQueryF AST) where + codeGenArgs (Applied imgQueryOp as) = do + bk <- view _backend + case bk of + SPIRV.OpenCL -> case imgQueryOp of + QueryLODF {} -> pure () + _ -> requireCapability SPIRV.ComputeKernel + SPIRV.Vulkan -> requireCapability SPIRV.ImageQuery + let + imgName :: ShortText + resultType :: SPIRV.PrimTy + ( imgName, resultType ) = imageQueryImageNameAndResultType imgQueryOp + resTyID <- typeID resultType + ( bdID, bindingTy ) <- bindingID imgName + + ( valID, valTy ) <- case bindingTy of + SPIRV.Pointer ptrTy + -> load imgName (Pointer bdID ptrTy) + _ -> throwError + ( "codeGen: internal error, image query operation on non-pointer named " + <> imgName <> " of type " <> ShortText.pack ( show bindingTy ) + ) + + -- LOD query operation needs a sampled image. + -- Other operations use a plain image. + imgID <- case valTy of + SPIRV.SampledImage imgTy + | QueryLODF {} <- imgQueryOp + -> pure valID + | otherwise + -> fst <$> removeSampler ( valID, imgTy ) + SPIRV.Image {} + | QueryLODF {} <- imgQueryOp + -> throwError + ( "codeGen: cannot query LOD of image named " <> imgName <> ":\n\ + \no sampler provided." + ) + | otherwise + -> pure valID + nonImgTy + -> throwError + ( "codeGen: image query operation on non-image named " <> imgName <> " of type " <> ShortText.pack ( show nonImgTy ) ) + + v <- fresh + let + emitInstruction :: CGMonad () + emitInstruction = case imgQueryOp of + QuerySizeF {} | NilAST <- as -> + instruction + Instruction + { operation = SPIRV.Op.ImageQuerySize + , resTy = Just resTyID + , resID = Just v + , args = Arg imgID EndArgs + } + QuerySizeLODF {} | (lod `ConsAST` NilAST) <- as -> do + lodID <- fst <$> codeGen lod + instruction + Instruction + { operation = SPIRV.Op.ImageQuerySizeLod + , resTy = Just resTyID + , resID = Just v + , args = Arg imgID + $ Arg lodID + $ EndArgs + } + QueryLODF {} | (coords `ConsAST` NilAST) <- as -> do + coordsID <- fst <$> codeGen coords + instruction + Instruction + { operation = SPIRV.Op.ImageQueryLod + , resTy = Just resTyID + , resID = Just v + , args = Arg imgID + $ Arg coordsID + $ EndArgs + } + QueryLevelsF {} | NilAST <- as -> + instruction + Instruction + { operation = SPIRV.Op.ImageQueryLevels + , resTy = Just resTyID + , resID = Just v + , args = Arg imgID EndArgs + } + QuerySamplesF {} | NilAST <- as -> + instruction + Instruction + { operation = SPIRV.Op.ImageQuerySamples + , resTy = Just resTyID + , resID = Just v + , args = Arg imgID EndArgs + } + emitInstruction + pure ( v, resultType ) + +imageQueryImageNameAndResultType :: ImgQueryF ast a -> ( ShortText, SPIRV.PrimTy ) +imageQueryImageNameAndResultType = \ case + QuerySizeF ( _ :: Proxy imgName ) ( _ :: Proxy resTy ) -> ( knownValue @imgName, primTy @resTy ) + QuerySizeLODF ( _ :: Proxy imgName ) ( _ :: Proxy resTy ) -> ( knownValue @imgName, primTy @resTy ) + QueryLODF ( _ :: Proxy imgName ) ( _ :: Proxy resTy ) -> ( knownValue @imgName, primTy @resTy ) + QueryLevelsF ( _ :: Proxy imgName ) ( _ :: Proxy resTy ) -> ( knownValue @imgName, primTy @resTy ) + QuerySamplesF ( _ :: Proxy imgName ) ( _ :: Proxy resTy ) -> ( knownValue @imgName, primTy @resTy ) diff --git a/src/CodeGen/Instruction.hs b/src/CodeGen/Instruction.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Instruction.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-| +Module: CodeGen.Instruction + +This module defines an 'Instruction' data type which collects the information associated to a SPIR-V instruction: + + * which instruction it is (essentially: the instruction's OpCode), + * the ID of the result returned by the instruction (if any), + * the ID of the return type of the instruction (if any), + * the arguments to the instruction (usually IDs, but can be other things such as string literals). +-} + + +module CodeGen.Instruction + ( Args(..), foldrArgs, arity, toArgs, Pair(..) + , ID(..), TyID(MkTyID, TyID, tyID) + , Instruction(..) + , prependArg, setArgs + , Pointer(..), Variable(..), variableID, variableDeclaration + ) where + +-- base +import Control.Category + ( (>>>) ) +import Data.Word + ( Word32 ) + +-- fir +import Data.Binary.Class.Put + ( Put(..) ) +import qualified SPIRV.Operation as SPIRV +import qualified SPIRV.PrimTy as SPIRV + ( PointerTy(..) ) + +---------------------------------------------------------------------------- +-- args + +data Args where + EndArgs :: Args + Arg :: ( Show a, Put a ) => a -> Args -> Args + +deriving stock instance Show Args + +-- mono-foldable business +foldrArgs :: (forall a. (Show a, Put a) => a -> b -> b) -> b -> Args -> b +foldrArgs _ b0 EndArgs = b0 +foldrArgs f b0 (Arg a as) = f a ( foldrArgs f b0 as ) + +instance Put Args where + put = foldrArgs (put >>> (>>)) (pure ()) + wordCount = foldrArgs ( (+) . wordCount ) 0 + +arity :: Num a => Args -> a +arity = foldrArgs (const (+1)) 0 + +toArgs :: ( Show a, Put a, Foldable t ) => t a -> Args +toArgs = foldr Arg EndArgs + +newtype Pair a b = Pair (a,b) + deriving stock Show +instance ( Put a, Put b ) => Put (Pair a b) where + put (Pair (a,b)) = put a *> put b + wordCount (Pair (a,b)) = wordCount a + wordCount b + +---------------------------------------------------------------------------- +-- instructions + +newtype ID = ID { idNumber :: Word32 } + deriving newtype ( Eq, Ord, Enum, Put ) + +instance Show ID where + show (ID n) = "%" ++ show n + +newtype TyID = TyID { tyID :: ID } + deriving newtype ( Eq, Ord, Enum, Put, Show ) + +pattern MkTyID :: Word32 -> TyID +pattern MkTyID i = TyID (ID i) + +data Instruction + = Instruction + { operation :: SPIRV.Operation + , resTy :: Maybe TyID + -- making 'resTy' and 'resID' of different types prevents accidentally mixing them up + , resID :: Maybe ID + , args :: Args + } + deriving stock Show + +prependArg :: ( Show a, Put a ) => a -> Instruction -> Instruction +prependArg arg instr@Instruction { args = oldArgs } + = instr { args = Arg arg oldArgs } + +setArgs :: Args -> Instruction -> Instruction +setArgs as instr = instr { args = as } + +---------------------------------------------------------------------------- +-- pointers and variables + +-- | A pointer, together with its type. +data Pointer + = Pointer + { pointerID :: ID + , pointerTy :: SPIRV.PointerTy + } + deriving stock Show + +-- | A variable: a pointer declared with an @OpVariable@ instruction, +-- together with the ID of its type. +data Variable + = Variable + { variablePointer :: Pointer + , variableTyID :: TyID + } + deriving stock Show + +-- | The ID of a variable. +variableID :: Variable -> ID +variableID = pointerID . variablePointer + +-- | The instruction declaring a variable. +variableDeclaration :: Variable -> Instruction +variableDeclaration ( Variable ( Pointer v ( SPIRV.PointerTy storage _ _ ) ) ptrTyID ) + = Instruction + { operation = SPIRV.Variable + , resTy = Just ptrTyID + , resID = Just v + , args = Arg storage EndArgs + } diff --git a/src/CodeGen/Monad.hs b/src/CodeGen/Monad.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Monad.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-| +Module: CodeGen.Monad + +Defines the monad used by the code generator, including the monadic state required for code generation. +-} + +module CodeGen.Monad + ( MonadFresh(fresh), runFreshSuccT + , CGMonad, putCG + , liftPut + , create, createID + , createRec, createIDRec + , tryToUse, tryToUseWith + , runExceptTPutM, runCGMonad + , note + ) + where + +-- base +import Control.Monad.Fix + ( MonadFix ) +import Control.Category + ( (>>>) ) + +-- binary +import Data.Binary + ( Binary ) +import qualified Data.Binary as Binary +import qualified Data.Binary.Put as Binary + +-- bytestring +import Data.ByteString.Builder + ( Builder, toLazyByteString ) +import Data.ByteString.Lazy + ( ByteString ) + +-- lens +import Control.Lens + ( Lens' + , use, assign, (<<%=) + ) + +-- mtl +import Control.Monad.Except + ( MonadError , ExceptT, runExceptT, throwError ) +import Control.Monad.Reader + ( MonadReader, ReaderT, runReaderT ) +import Control.Monad.State + ( MonadState , StateT , runStateT ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- transformers +import Control.Monad.Trans.Class + ( MonadTrans, lift ) +import Control.Monad.Trans.Writer.Lazy + ( Writer, runWriter, tell ) + +-- fir +import Control.Arrow.Strength + ( leftStrength ) +import CodeGen.Instruction + ( ID ) +import CodeGen.State + ( CGState, CGContext + , _currentID + ) + +---------------------------------------------------------------------------- +-- monad for code generation + +type CGMonad + = FreshSuccT CGState -- supply of fresh variable IDs using CGState (see below) + ( ReaderT CGContext -- context for code generation + ( StateT CGState -- state (including for instance a map of which types have been defined) + ( ExceptT ShortText -- for errors during code generation + ( Writer Builder ) -- to write instructions in binary form + ) + ) + ) +-- NB: all the layers of this monad are lazy, so that we can tie knots using 'mfix'. +deriving newtype instance MonadReader CGContext CGMonad +deriving newtype instance MonadError ShortText CGMonad +-- other instances automatically derived from the definition of FreshSuccT: +-- Functor, Applicative, Monad, MonadState CGState, MonadFresh ID + +liftPut :: Binary.Put -> CGMonad () +liftPut = lift . lift . lift . lift . tell . Binary.execPut -- apologies + +putCG :: Binary a => a -> CGMonad () +putCG = liftPut . Binary.put + +---------------------------------------------------------------------------- +-- fresh name generation + +class HasSupply v s where + supply :: Lens' s v + +instance HasSupply ID CGState where + supply = _currentID + +instance HasSupply ID ID where + supply = id + +class Monad m => MonadFresh v m where + fresh :: m v + +newtype FreshSuccT s m a = FreshSuccT { runFreshSuccT :: m a } + +deriving newtype instance Functor m => Functor (FreshSuccT s m) +deriving newtype instance Applicative m => Applicative (FreshSuccT s m) +deriving newtype instance Monad m => Monad (FreshSuccT s m) +deriving newtype instance MonadState s m => MonadState s (FreshSuccT s m) +deriving newtype instance MonadFix m => MonadFix (FreshSuccT s m) + +instance MonadTrans (FreshSuccT s) where + lift = FreshSuccT + +instance (MonadState s m, HasSupply v s, Enum v) => MonadFresh v (FreshSuccT s m) where + fresh = supply <<%= succ -- <<%= means: "modify, and return the _old_ value" + +create :: ( MonadFresh v m, MonadState s m ) + => Lens' s (Maybe a) -> (v -> m a) -> m (v, a) +create _key mk + = do v <- fresh + a <- mk v + assign _key ( Just a ) + pure (v, a) + +createID :: ( MonadFresh v m, MonadState s m ) + => Lens' s (Maybe a) -> (v -> m a) -> m v +createID _key mk = fst <$> create _key mk + +createRec :: ( MonadFresh v m, MonadState s m ) + => Lens' s (Maybe a) -> m b -> (b -> v -> m a) -> m (v, a) +createRec _key before mk + = do b <- before + v <- fresh + a <- mk b v + assign _key ( Just a ) + pure (v, a) + +createIDRec :: ( MonadFresh v m, MonadState s m ) + => Lens' s (Maybe a) -> m b -> (b -> v -> m a) -> m v +createIDRec _key before mk = fst <$> createRec _key before mk + +-- | Try to use a given lens to obtain a value. +-- +-- If using the lens returns Nothing, create the value instead, using 'create'. +tryToUse :: ( MonadFresh v m, MonadState s m ) + => Lens' s (Maybe a) -> (a -> b) -> (v -> m a) -> m b +tryToUse _key f mk = tryToUseWith _key f ( f . snd <$> create _key mk ) + +-- | Like 'tryToUse', but allowing for a custom creation procedure. +tryToUseWith :: ( MonadState s m ) + => Lens' s (Maybe a) -> (a -> b) -> m b -> m b +tryToUseWith _key f creation = + use _key >>= maybe creation (pure . f) + +---------------------------------------------------------------------------- +-- running the code generation monad + +runExceptTPutM :: ExceptT e Binary.PutM a -> Either e (a, ByteString) +runExceptTPutM = runExceptT >>> uncurry leftStrength . Binary.runPutM + +runCGMonad :: CGContext -> CGState -> CGMonad r -> Either ShortText (r, CGState, ByteString) +runCGMonad context state + = runFreshSuccT + >>> ( `runReaderT` context ) + >>> ( `runStateT` state ) + >>> runExceptT + >>> runWriter + >>> \ ( res, b ) -> fmap ( \ ( r, s ) -> ( r, s, toLazyByteString b ) ) res + +---------------------------------------------------------------------------- +-- utility for exceptions + +note :: forall m a e. MonadError e m => e -> Maybe a -> m a +note _ (Just a) = pure a +note e Nothing = throwError e diff --git a/src/CodeGen/Optics.hs b/src/CodeGen/Optics.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Optics.hs @@ -0,0 +1,918 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +{-| +Module: CodeGen.Optics + +Code generation for operations involving the type-level optics used by this library, +such as @view@, @set@, @use@, @assign@. + +-} + +module CodeGen.Optics ( ) where + +-- base +import Control.Arrow + ( first ) +import Control.Monad + ( unless ) +import Data.Foldable + ( traverse_ ) +import Data.Kind + ( Type ) +import Data.Proxy + ( Proxy(Proxy) ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import Data.Typeable + ( eqT ) +import Data.Word + ( Word32 ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- lens +import Control.Lens + ( assign ) + +-- mtl +import Control.Monad.Except + ( throwError ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( pack ) + +-- fir +import CodeGen.Application + ( ASTs(NilAST, ConsAST), pattern SnocAST + , Codes, pattern ConsCode + , Application(..) + ) +import {-# SOURCE #-} CodeGen.CodeGen + ( CodeGen(codeGenArgs), codeGen ) +import CodeGen.Composite + ( compositeConstruct + , compositeExtract + , compositeInsert + , vectorSwizzle + , productConstruct + ) +import CodeGen.Debug + ( whenAsserting ) +import CodeGen.IDs + ( constID, bindingID, typeID ) +import CodeGen.Images + ( imageTexel, writeTexel ) +import CodeGen.Instruction + ( ID(ID), Pointer(..) ) +import CodeGen.Monad + ( CGMonad ) +import CodeGen.Pointers + ( Safeness(Safe, Unsafe) + , Indices(RTInds, CTInds) + , temporaryVariable, accessChain + , load, store + , loadInstruction, storeInstruction + ) +import CodeGen.Atomics + ( atomicInstruction ) +import CodeGen.State + ( PointerState(Fresh, Modified) + , _localBinding + , setTemporaryPointer + ) +import Control.Type.Optic + ( Optic + , ProductComponents(..) ) +import Data.Constraint.All + ( All(allDict) + , AllDict(NilDict, ConsDict) + ) +import Data.Product + ( HList(HNil, (:>)) + , MapHList + , IsProduct(toHList) + , AreProducts(productsDict) + , AreProductsDict(ConsProducts) + , Distribute + , distributeZipConsLemma1 + ) +import Data.Type.Known + ( knownValue ) +import Data.Type.List + ( type (:++:), ZipCons + , KnownLength(sLength) + , SLength(SZero, SSucc) + , SameLength(sSameLength) + , SSameLength(SSameZero, SSameSucc) + , Snoc + ) +import FIR.AST + ( AST, Code + , pattern (:$), pattern Lit + , pattern MkID + , pattern NilHList, pattern ConsHList + , OpticF(..) + ) +import FIR.AST.Type + ( AugType(Val), MapVal ) +import FIR.Prim.Atomic + ( SAtomicOp, atomicOp, SAtomicShape(..), atomicShape ) +import FIR.Prim.Types + ( PrimTy, primTy, primTys + , SPrimTy(..), sPrimTy + ) +import FIR.Syntax.Optics + ( SOptic(..), showSOptic + , SProductComponents(..) + ) +import qualified SPIRV.PrimTy as SPIRV + +---------------------------------------------------------------------------- +-- Code generation for optics. + +data OpticArgs where + OpticView :: forall is s a (optic :: Optic is s a). SOptic optic -> Codes is -> Code s -> OpticArgs + OpticSet :: forall is s a (optic :: Optic is s a). SOptic optic -> Codes is -> Code a -> Code s -> OpticArgs + OpticUse :: forall is s a (optic :: Optic is s a). SOptic optic -> Codes is -> OpticArgs + OpticAssign :: forall is s a (optic :: Optic is s a). SOptic optic -> Codes is -> Code a -> OpticArgs + OpticAtomic :: forall is s a (optic :: Optic is s a) op + . SAtomicOp op -> SOptic optic -> Codes is -> [ Code a ] + -> OpticArgs + +opticArgs :: Application (OpticF AST) f r -> OpticArgs +opticArgs ( Applied ( ViewF _ ( sOptic :: SOptic ( optic :: Optic is s a) ) ) is_s ) = + case unsafeCoerce is_s :: ( ASTs (MapVal is `Snoc` Val s) ) of + ( is `SnocAST` s ) -> OpticView sOptic is s +opticArgs ( Applied ( SetF _ ( sOptic :: SOptic ( optic :: Optic is s a) ) ) is_a_s ) = + case unsafeCoerce is_a_s :: ( ASTs ( MapVal is `Snoc` Val a `Snoc` Val s ) ) of + ( is `SnocAST` a `SnocAST` s ) -> OpticSet sOptic is a s +opticArgs ( Applied ( UseF _ ( sOptic :: SOptic ( optic :: Optic is s a) ) ) is ) = + case unsafeCoerce is :: ASTs ( MapVal is ) of + js -> OpticUse sOptic js +opticArgs ( Applied ( AssignF _ ( sOptic :: SOptic ( optic :: Optic is s a) ) ) is_a ) = + case unsafeCoerce is_a :: ( ASTs ( MapVal is `Snoc` Val a ) ) of + ( is `SnocAST` a ) -> OpticAssign sOptic is a +opticArgs ( Applied ( AtomicF sOp _ ( sOptic :: SOptic ( optic :: Optic is s a) ) ) is_vs ) = + case atomicShape sOp of + SReads -> + OpticAtomic sOp sOptic ( unsafeCoerce is_vs :: Codes is ) [] + SWrites -> + case unsafeCoerce is_vs :: ( ASTs ( MapVal is `Snoc` Val a ) ) of + ( is `SnocAST` v ) -> OpticAtomic sOp sOptic is [ v ] + SModifies -> + case unsafeCoerce is_vs :: ( ASTs ( MapVal is `Snoc` Val a ) ) of + ( is `SnocAST` v ) -> OpticAtomic sOp sOptic is [ v ] + SCompares -> + case unsafeCoerce is_vs :: ( ASTs ( MapVal is `Snoc` Val a `Snoc` Val a ) ) of + ( is `SnocAST` expected `SnocAST` new ) + -> OpticAtomic sOp sOptic is [ expected, new ] + + +instance CodeGen AST => CodeGen (OpticF AST) where + + codeGenArgs opticApplication = case opticArgs opticApplication of { + + -- View. + OpticView sOptic is s -> do + base <- codeGen s + extractUsingGetter base sOptic is + + ; + -- Set. + OpticSet sOptic is a s -> do + setUsingSetter s a sOptic is + + ; + -- Use. + OpticUse sOptic is -> case sOptic of + + SBinding (_ :: Proxy name) -> + do let varName = knownValue @name + bd@(bdID, bdTy) <- bindingID varName + case bdTy of + SPIRV.Pointer ptrTy + -> load varName (Pointer bdID ptrTy) + _ -> pure bd + + -- image + SImageTexel ( _ :: Proxy name ) ( _ :: Proxy props ) texelTy + -> case is of + ( ops `ConsAST` coords `ConsAST` NilAST ) + -> do + let imgName = knownValue @name + imgTexelTy = sPrimTy texelTy + bd@(bdID, bdTy) <- bindingID imgName + resTyID <- typeID imgTexelTy + img <- case bdTy of + SPIRV.Pointer ptrTy + -> load imgName (Pointer bdID ptrTy) + _ -> pure bd + (cdID, _) <- codeGen coords + imageTexel img ops cdID (resTyID, imgTexelTy) + + SComposeO _ (SBinding (_ :: Proxy name )) getter -> + do let varName = knownValue @name + bd@(bdID, bdTy) <- bindingID varName + + case bdTy of + SPIRV.Pointer ptrTy + -> loadThroughAccessChain (Pointer bdID ptrTy) getter is + _ -> extractUsingGetter bd getter is + + SComposeO + (SSucc (SSucc _)) + (SImageTexel ( _ :: Proxy name ) ( _ :: Proxy props ) texelTy) + getter + -> case is of + ( ops `ConsAST` coords `ConsAST` nextindices ) + -> + do + -- copy-pasted from above + let imgName = knownValue @name + imgTexelTy = sPrimTy texelTy + bd@(bdID, bdTy) <- bindingID imgName + resTyID <- typeID imgTexelTy + img <- case bdTy of + SPIRV.Pointer ptrTy + -> load imgName (Pointer bdID ptrTy) + _ -> pure bd + (cdID, _) <- codeGen coords + -- end of copy-paste + texel <- imageTexel img ops cdID (resTyID, imgTexelTy) + extractUsingGetter texel getter nextindices + + _ -> throwError ( "codeGen: cannot 'use', unsupported optic:\n" + <> ShortText.pack (showSOptic sOptic) <> "\n" + <> "Optic does not start by accessing a binding (or image texel).\n" + ) + + ; + -- Assign. + OpticAssign sOptic is a -> case sOptic of + + SBinding (_ :: Proxy name) -> + do let varName = knownValue @name + a_IDTy@(a_ID, _) <- codeGen a + (bdID, bdTy) <- bindingID varName + + case bdTy of + SPIRV.Pointer ptrTy + -> store varName (Pointer bdID ptrTy) a_ID + _ -> assign ( _localBinding varName ) (Just a_IDTy) + + pure (ID 0, SPIRV.Unit) -- ID should never be used + + -- image + SImageTexel ( _ :: Proxy name ) ( _ :: Proxy props ) _ + -> case is of + ( ops `ConsAST` coords `ConsAST` NilAST ) + -> do + let imgName = knownValue @name + bd@(bdID, bdTy) <- bindingID imgName + img <- case bdTy of + SPIRV.Pointer ptrTy + -> load imgName (Pointer bdID ptrTy) + _ -> pure bd + (cdID , _) <- codeGen coords + (texID, _) <- codeGen a + writeTexel img ops cdID texID + pure (ID 0, SPIRV.Unit) -- ID should never be used + + SComposeO _ (SBinding (_ :: Proxy name)) setter -> + do let varName = knownValue @name + bd@(bdID, bdTy) <- bindingID varName + + case bdTy of + SPIRV.Pointer ptrTy + -> storeThroughAccessChain (Pointer bdID ptrTy) a setter is + _ -> insertUsingSetter varName bd a setter is + + pure (ID 0, SPIRV.Unit) -- ID should never be used + + SComposeO _ SImageTexel {} _ + -> throwError ( "codeGen: writing to individual components \ + \of an image texel currently unsupported" + ) + + _ -> throwError ( "codeGen: cannot 'assign', unsupported optic:\n" + <> ShortText.pack (showSOptic sOptic) <> "\n" + <> "Optic does not start by accessing a binding." + ) + + ; + -- Atomic operation. + OpticAtomic sOp sOptic is operands -> do + let opName = ShortText.pack ( show ( atomicOp sOp ) ) + ptr <- opticPointer opName sOptic is + operandIDs <- traverse ( fmap fst . codeGen ) operands + atomicInstruction sOp ptr operandIDs + + } + +---------------------------------------------------------------------------- +-- Pointers denoted by optics. + +-- | The pointer an optic focuses on: the optic must start with a binding of +-- pointer type, possibly followed by an access chain. +opticPointer + :: forall is s a (optic :: Optic is s a) + . CodeGen AST + => ShortText -- ^ Name of the operation (for error messages). + -> SOptic optic + -> Codes is + -> CGMonad Pointer +opticPointer opName sOptic is = case sOptic of + SBinding ( _ :: Proxy name ) -> + bindingPointer ( knownValue @name ) + SComposeO _ ( SBinding ( _ :: Proxy name ) ) accessor -> do + basePtr <- bindingPointer ( knownValue @name ) + pointerThroughAccessChain' opName basePtr =<< operationTree is accessor + _ -> unsupported "Optic does not start by accessing a binding." + where + bindingPointer :: ShortText -> CGMonad Pointer + bindingPointer varName = do + (bdID, bdTy) <- bindingID varName + case bdTy of + SPIRV.Pointer ptrTy + -> pure ( Pointer bdID ptrTy ) + _ -> unsupported + ( "Binding \"" <> varName <> "\" is not of pointer type." ) + unsupported :: ShortText -> CGMonad x + unsupported reason = + throwError ( "codeGen: cannot '" <> opName <> "', unsupported optic:\n" + <> ShortText.pack (showSOptic sOptic) <> "\n" + <> reason + ) + +---------------------------------------------------------------------------- +-- Perform code-generation by computing associated optical trees. + +-- | Load through a pointer with the supplied getter. +loadThroughAccessChain + :: forall is s a (optic :: Optic is s a) + . CodeGen AST + => Pointer -> SOptic optic -> Codes is -> CGMonad (ID, SPIRV.PrimTy) +loadThroughAccessChain basePtr sOptic is + = loadThroughAccessChain' basePtr =<< operationTree is sOptic + +-- | Use a getter to @view@ a part of the provided object. +extractUsingGetter + :: forall is s a (optic :: Optic is s a) + . CodeGen AST + => (ID, SPIRV.PrimTy) -> SOptic optic -> Codes is -> CGMonad (ID, SPIRV.PrimTy) +extractUsingGetter base sOptic is + = extractUsingGetter' base =<< operationTree is sOptic + +-- | Store into a pointer with the supplied setter. +storeThroughAccessChain + :: forall is s a (optic :: Optic is s a) + . CodeGen AST + => Pointer -> Code a -> SOptic optic -> Codes is -> CGMonad () +storeThroughAccessChain basePtr val sOptic is + = storeThroughAccessChain' basePtr val =<< operationTree is sOptic + +-- | Set a component of an object, with focus given by the supplied setter. +-- +-- Returns the updated object. +setUsingSetter + :: forall is s a (optic :: Optic is s a) + . CodeGen AST + => Code s + -> Code a + -> SOptic optic + -> Codes is + -> CGMonad (ID, SPIRV.PrimTy) +setUsingSetter base val sOptic is = do + baseID <- codeGen base + tree <- operationTree is sOptic + setUsingSetter' baseID val tree + +-- | Set a component of a binding, with focus given by the supplied setter. +-- +-- Doesn't return anything: updates the state of the provided binding. +insertUsingSetter + :: forall is s a (optic :: Optic is s a) + . CodeGen AST + => ShortText -> (ID, SPIRV.PrimTy) -> Code a -> SOptic optic -> Codes is -> CGMonad () +insertUsingSetter varName base val sOptic is = do + tree <- operationTree is sOptic + insertUsingSetter' varName base val tree + +---------------------------------------------------------------------------- +-- Optical trees. + +data OpticalNode where + Access :: Safeness -> Indices -> OpticalNode + OfTypeOp :: SPrimTy s -> SPrimTy a -> OpticalNode + Combine :: (PrimTy p, All PrimTy as, IsProduct p as) + => Proxy p -> Proxy as -> [ OpticalOperationTree ] -> OpticalNode + +instance Show OpticalNode where + show (Access safe is) = "Access " ++ show safe ++ " " ++ show is + show (OfTypeOp s a) = "OfTypeOp @" ++ show s ++ " @" ++ show a + show (Combine (_ :: Proxy p) ( _ :: Proxy as) trees) + = "Combine @" ++ show (primTy @p) ++ " @" ++ show (primTys @as) + ++ " " ++ show trees + +type OpticalOperationTree = [ OpticalNode ] + +operationTree + :: forall k is (s :: k) a (optic :: Optic is s a) + . CodeGen AST + => Codes is -> SOptic optic -> CGMonad OpticalOperationTree +operationTree _ (SOfType s a) = pure [OfTypeOp s a] +operationTree (i `ConsAST` _) SAnIndex {} + = (:[]) . Access Unsafe . RTInds . (:[]) . fst <$> codeGen i +operationTree _ (SIndex s _ n) + -- if accessing a runtime array, a compile-time index may be unsafe + | SRuntimeArray <- s + = pure [ Access Unsafe (CTInds [n]) ] + -- otherwise, a compile-time index is guaranteed to be in-bounds + | otherwise + = pure [ Access Safe (CTInds [n]) ] +operationTree is (SComposeO lg1 opt1 opt2) + = do let (is1, is2) = composedIndices lg1 is + ops1 <- operationTree is1 opt1 + ops2 <- operationTree is2 opt2 + ops1 `continue` ops2 +operationTree is + ( SProd same (comps :: SProductComponents (os :: ProductComponents iss s as)) + :: SOptic (optic :: Optic is s a) + ) = do + comp_indices <- combinedIndices @iss @is @as sSameLength sLength is + comp_trees <- componentsTrees same comps comp_indices + case comp_trees of + [] -> return [] + [ tree ] -> return tree + trees -> return [ Combine ( Proxy @a ) ( Proxy @as ) trees ] + -- N.B.: only combine optical subtrees when there is combining taking place. + -- If there are fewer than 2 subtrees, we won't be creating a composite structure. + -- See bug #88. +operationTree _ (SBinding {}) + = throwError "operationTree: trying to access a binding within a binding" +operationTree _ (SImageTexel {}) + = throwError "operationTree: unexpected image optic" + +continue :: OpticalOperationTree -> OpticalOperationTree -> CGMonad OpticalOperationTree +continue ops1 [] = pure ops1 +continue [] ops2 = pure ops2 +-- try to combine successive accesses into a single access chain as much as possible +-- (this helps bypass Vulkan implementation bugs in tessellation evaluation shaders) +continue [Access safe1 (CTInds is1)] (Access safe2 (CTInds is2) : ops2) + = pure $ Access (safe1 <> safe2) (CTInds (is1 ++ is2)) : ops2 +continue [Access safe1 (RTInds is1)] (Access safe2 (RTInds is2) : ops2) + = pure $ Access (safe1 <> safe2) (RTInds (is1 ++ is2)) : ops2 +continue [Access safe1 (CTInds is1)] (Access safe2 (RTInds is2) : ops2) + = do + js1 <- traverse constID is1 + pure $ ( Access (safe1 <> safe2) (RTInds (js1 ++ is2)) : ops2 ) +continue [Access safe1 (RTInds is1)] (Access safe2 (CTInds is2) : ops2) + = do + js2 <- traverse constID is2 + pure $ Access (safe1 <> safe2) (RTInds (is1 ++ js2)) : ops2 +continue (op1 : ops1) ops2 + = do + cont <- ops1 `continue` ops2 + pure $ op1 : cont + +componentsTrees + :: forall + (k :: Type) (iss :: [[Type]]) (s :: k) + (as :: [Type]) (os :: ProductComponents iss s as) + . CodeGen AST + => SSameLength (Distribute iss as) as + -> SProductComponents os + -> Codes (MapHList (Distribute iss as)) + -> CGMonad [OpticalOperationTree] +componentsTrees _ SEndProd _ + = pure [] +componentsTrees sameSucc@(SSameSucc lg) (so `SProductO` sos) (is `ConsAST` iss) = + case sameSucc of + ( _ :: SSameLength (ds ': dss) (b ': bs) ) -> + case so of + ( _ :: SOptic ( o :: Optic es s b ) ) -> + case sos of + ( _ :: SProductComponents ( tail_os :: ProductComponents ess s bs ) ) -> + case distributeZipConsLemma1 @b @bs @ds @dss @es @ess of + (Refl, Refl) -> + (:) <$> operationTree (astsFromHList is) so <*> componentsTrees lg sos iss + +composedIndices :: SLength is -> Codes (is :++: js) -> (Codes is, Codes js) +composedIndices SZero js = ( NilAST, js ) +composedIndices (SSucc tail_is) (k `ConsAST` ks) + = first ( k `ConsAST` ) ( composedIndices tail_is ks ) + +combinedIndices + :: forall (jss :: [[Type]]) (is :: [Type]) (as :: [Type]) + . ( CodeGen AST, AreProducts is jss as ) + => SSameLength is jss + -> SLength as + -> Codes is + -> CGMonad (Codes (MapHList (Distribute jss as))) +combinedIndices SSameZero SZero NilAST + = pure $ NilAST +combinedIndices SSameZero (SSucc lg) NilAST + = (NilHList `ConsAST`) <$> combinedIndices SSameZero lg NilAST +combinedIndices sSame@(SSameSucc sm) lg (i `ConsAST` is) = + case sSame of + ( _ :: SSameLength (p ': ps) (es ': ess) ) -> + case productsDict @is @jss @as of + ConsProducts -> + zipIndices @es @(Distribute ess as) allDict sSameLength + <$> deconstruct allDict i + <*> combinedIndices sm lg is + +zipIndices + :: AllDict PrimTy is + -> SSameLength is jss + -> Codes is + -> Codes (MapHList jss) + -> Codes (MapHList (ZipCons is jss)) +zipIndices NilDict SSameZero NilAST NilAST = NilAST +zipIndices ConsDict (SSameSucc lg) (i `ConsAST` is) (js `ConsAST` jss) = + (ConsHList :$ i :$ js) `ConsAST` zipIndices allDict lg is jss + +deconstruct + :: forall (p :: Type) (as :: [Type]) + . ( CodeGen AST, IsProduct p as ) + => AllDict PrimTy as -> Code p -> CGMonad (Codes as) +deconstruct NilDict _ = pure NilAST +deconstruct dict (Lit x) = pure $ hListToASTs dict (toHList @p @as x) +deconstruct dict p + | Just hlist <- recogniseHList dict p + = pure hlist + -- TODO: more cases to avoid spurious "compositeConstruct ---> compositeExtract" +deconstruct ConsDict p = do + composite <- codeGen p + compositeExtractAll composite allDict 0 + + +recogniseHList :: AllDict PrimTy as -> Code p -> Maybe (Codes as) +recogniseHList NilDict _ = Just NilAST +recogniseHList consDict@ConsDict ast + = case consDict of + ( _ :: AllDict PrimTy (b ': bs) ) -> + case ast of + ( ConsHList :$ (c :: Code c) :$ cs ) + | Just Refl <- eqT @b @c + -> (c `ConsAST`) <$> recogniseHList allDict cs + _ -> Nothing + +astsFromHList :: Code (HList as) -> Codes as +astsFromHList NilHList + = NilAST +astsFromHList (ConsHList :$ a :$ as) + = a `ConsAST` astsFromHList as +astsFromHList _ + = error "'operationTree': indexing heterogenous list AST not of the expected form (TODO?)" + +hListToASTs :: AllDict PrimTy as -> HList as -> Codes as +hListToASTs _ HNil = NilAST +hListToASTs ConsDict (a :> as) = Lit a `ConsAST` hListToASTs allDict as + +compositeExtractAll + :: forall (as :: [Type]) + . CodeGen AST + => (ID, SPIRV.PrimTy) + -> AllDict PrimTy as + -> Word32 + -> CGMonad (Codes as) +compositeExtractAll _ NilDict _ = pure NilAST +-- special case for matrix entries: +-- product for matrices can use individual components (rather than just columns) +compositeExtractAll comp@(_,compTy) dict@ConsDict i + | SPIRV.Matrix {..} <- compTy + , SPIRV.Scalar entryTy == expectedTy + = do + extracted <- traverse (compositeExtract comp) $ [ [i,j] | j <- [0..pred rows] ] + makeIDsAndContinue (succ i) dict extracted + + where + expectedTy :: SPIRV.PrimTy + expectedTy = case dict of + ( _ :: AllDict PrimTy (b ': bs) ) + -> primTy @b + + makeIDsAndContinue + :: Word32 + -> AllDict PrimTy ts + -> [(ID, SPIRV.PrimTy)] + -> CGMonad (Codes ts) + makeIDsAndContinue _ NilDict _ = pure NilAST + makeIDsAndContinue nxt dict' [] = compositeExtractAll comp dict' nxt + makeIDsAndContinue nxt dict'@ConsDict + ( extract@(_,extractedTy) : extracts ) = + case dict' of + ( _ :: AllDict PrimTy (c ': cs) ) + -> do + whenAsserting . unless ( expectedTy == extractedTy ) $ + throwError $ + "'compositeExtractAll': ASSERT failed\n" + <> "expected type" <> ShortText.pack (show expectedTy) + <> ", but composite component " <> ShortText.pack (show i) + <> " has type " <> ShortText.pack (show extractedTy) + + next <- makeIDsAndContinue nxt allDict extracts + pure $ MkID extract `ConsAST` next +-- usual case +compositeExtractAll comp ConsDict i = + do + extracted <- compositeExtract comp [i] + next <- compositeExtractAll comp allDict (succ i) + pure $ MkID extracted `ConsAST` next + +---------------------------------------------------------------------------- +-- Generate code for a tree of optical operations. + +-- check whether a vector swizzle operation can be used +swizzleIndices :: SPIRV.PrimTy -> [OpticalOperationTree] -> Maybe [Word32] +swizzleIndices (SPIRV.Vector _ _) = traverse simpleIndex + where + simpleIndex :: OpticalOperationTree -> Maybe Word32 + simpleIndex [Access Safe (CTInds [i])] = Just i + simpleIndex _ = Nothing +swizzleIndices _ = const Nothing + +loadThroughAccessChain' + :: CodeGen AST + => Pointer -> OpticalOperationTree -> CGMonad (ID, SPIRV.PrimTy) +loadThroughAccessChain' basePtr [] + = loadInstruction basePtr +loadThroughAccessChain' basePtr ( Access safe is : ops ) + = do + newBasePtr <- accessChain basePtr safe is + loadThroughAccessChain' newBasePtr ops +loadThroughAccessChain' basePtr@(Pointer _ (SPIRV.PointerTy _ _ eltTy)) ( Combine (_ :: Proxy p) _ trees : ops ) + -- special case: can we use a vector swizzle operation? + | Just is <- swizzleIndices eltTy trees + = do + base <- loadThroughAccessChain' basePtr [] + vec <- vectorSwizzle base is + extractUsingGetter' vec ops + | otherwise + = do + subtrees <- traverse (loadThroughAccessChain' basePtr) trees + combined <- productConstruct (primTy @p) subtrees + extractUsingGetter' combined ops +loadThroughAccessChain' _ ( OfTypeOp _ _ : _ ) + = throwError "loadThroughAccessChain': unexpected 'OfType' optic used as a getter" + +-- | Follow a pointer through a tree of optical operations, which must be an +-- access chain (no product or 'OfType' optics). +pointerThroughAccessChain' + :: ShortText -- ^ Name of the operation (for error messages). + -> Pointer -> OpticalOperationTree -> CGMonad Pointer +pointerThroughAccessChain' _ basePtr [] + = pure basePtr +pointerThroughAccessChain' opName basePtr ( Access safe is : ops ) + = do + newBasePtr <- accessChain basePtr safe is + pointerThroughAccessChain' opName newBasePtr ops +pointerThroughAccessChain' opName _ ( OfTypeOp {} : _ ) + = throwError ( "codeGen: cannot '" <> opName <> "' through an 'OfType' \ + \optic, which does not denote a pointer." ) +pointerThroughAccessChain' opName _ ( Combine {} : _ ) + = throwError ( "codeGen: cannot '" <> opName <> "' through a product \ + \optic, which does not denote a pointer." ) + + +extractUsingGetter' + :: CodeGen AST + => (ID, SPIRV.PrimTy) -> OpticalOperationTree -> CGMonad (ID, SPIRV.PrimTy) +extractUsingGetter' base [] + = pure base +extractUsingGetter' base tree@( Access _ (CTInds is) : ops ) + = do + whenAsserting + case base of + ( _, SPIRV.Scalar _ ) -> + throwError + ( "extractUsingGetter': ASSERT failed, trying to extract from a scalar type\n\ + \base = " <> ShortText.pack ( show base ) <> "\n\ + \tree = " <> ShortText.pack ( show tree ) + ) + _ -> pure () + newBase <- compositeExtract base is + extractUsingGetter' newBase ops +extractUsingGetter' base@(baseID, _) ops@( Access _ (RTInds _) : _ ) + -- run-time indices: revert to loading through pointers + = do + (basePtr, basePtrState) <- temporaryVariable base + unless + ( basePtrState == Fresh ) + ( do storeInstruction basePtr baseID + -- reset temporary pointer to "fresh" as we just loaded the baseID into it + setTemporaryPointer baseID (basePtr, Fresh) + ) + loadThroughAccessChain' basePtr ops +extractUsingGetter' base@(_, eltTy) ( Combine (_ :: Proxy p) _ trees : ops ) + -- special case: can we use a vector swizzle operation? + | Just is <- swizzleIndices eltTy trees + = do + vec <- vectorSwizzle base is + extractUsingGetter' vec ops + | otherwise + = do + subtrees <- traverse (extractUsingGetter' base) trees + combined <- productConstruct (primTy @p) subtrees + extractUsingGetter' combined ops +extractUsingGetter' _ ( OfTypeOp _ _ : _ ) + = throwError "extractUsingGetter': unexpected 'OfType' optic used as a getter" + + +storeThroughAccessChain' + :: CodeGen AST + => Pointer -> Code a -> OpticalOperationTree -> CGMonad () +-- Base case: identity. +storeThroughAccessChain' basePtr val [] + = storeInstruction basePtr =<< fst <$> codeGen val +-- Access. +storeThroughAccessChain' basePtr val ( Access safe is : ops ) + = do + newBasePtr <- accessChain basePtr safe is + storeThroughAccessChain' newBasePtr val ops +-- OfType optic. +storeThroughAccessChain' basePtr val ( OfTypeOp _ a : ops ) + = storeAtTypeThroughAccessChain basePtr val ops (sPrimTy a) [ wholeObject basePtr ] +-- Product optic. +-- This is a bit more tricky and requires a second level of recursion. +-- +-- * Base case. +storeThroughAccessChain' basePtr val ( Combine (_ :: Proxy p) (_ :: Proxy as) trees : [] ) + = successiveStores basePtr trees =<< deconstruct @p @as allDict (unsafeCoerce val) +-- * Access. +storeThroughAccessChain' _ _ ( Combine {} : Access {} : _ ) + = throwError "storeThroughAccessChain': currently unsupported composition ( product optic - indexing )" +-- * OfType optic. +-- If "OfType ty" pertains to the individual components, then we can +-- perform a 'storeAtTypeThroughAccessChain' on all the components in turn. +-- We must first catch the other cases: focus onto a part that arose from the creation of the product type. +storeThroughAccessChain' basePtr val ( Combine (px_p :: Proxy p) (px_as :: Proxy as) trees : OfTypeOp _ a : ops ) + -- Start off by catching situations where we focus on a part that arose from the product. + -- * 'Combine' followed by 'OfType combinedTy': can ignore 'OfType combinedTy' (identity lens). + | combinedTy == ofTypeTy + = storeThroughAccessChain' basePtr val ( Combine px_p px_as trees : ops ) + -- * Finicky corner case: we are combining entries (not columns) to form a matrix, but followed by `OfType colTy`. + | SPIRV.Matrix m _ eltTy <- combinedTy + , ( SPIRV.Scalar eltTy' : _ ) <- compTys + , eltTy' == eltTy + , ( SPIRV.Vector m' (SPIRV.Scalar eltTy'') ) <- ofTypeTy + , eltTy'' == eltTy && m' == m + = throwError "storeThroughAccessChain': currently unsupported corner case \ + \(matrix product of entries followed by 'OfType' optic focused on column type)" + -- General case: call 'storeAtTypeThroughAccessChain' on all the components in turn. + | otherwise + = storeAtTypeThroughAccessChain basePtr val ops ofTypeTy ( zipWith Component trees compTys ) + where + combinedTy, ofTypeTy :: SPIRV.PrimTy + compTys :: [SPIRV.PrimTy] + combinedTy = primTy @p + ofTypeTy = sPrimTy a + compTys = primTys @as +-- * Second product optic. +storeThroughAccessChain' _ _ ( Combine {} : Combine {} : _ ) + = throwError "storeThroughAccessChain': currently unsupported composition ( product optic - product optic )" + + +-- | Store into all the subcomponents of the given type of the given components, +-- applying the given operations to each of these subcomponents. +storeAtTypeThroughAccessChain + :: CodeGen AST + => Pointer + -> Code a + -> OpticalOperationTree + -> SPIRV.PrimTy + -> [ Component ] + -> CGMonad () +storeAtTypeThroughAccessChain basePtr val ops a = traverse_ go + where + go :: Component -> CGMonad () + go comp + | componentTy comp == a + = storeInto basePtr comp val ops + | [] <- ops + , Just filled <- replicated ( componentTy comp ) + = do + v <- filled + storeInto basePtr comp ( MkID v ) [] + | otherwise + = traverse_ go =<< subcomponents comp + + -- A vector or matrix whose entries (or columns) are all of the given type + -- can be stored into all at once. + replicated :: SPIRV.PrimTy -> Maybe ( CGMonad (ID, SPIRV.PrimTy) ) + replicated ty = case ty of + SPIRV.Vector n elt + | elt == a + -> Just $ fill ty n =<< value + SPIRV.Matrix m n elt + | a == colTy + -> Just $ fill ty n =<< value + | a == SPIRV.Scalar elt + -> Just $ fill ty n . fst =<< fill colTy m =<< value + where + colTy :: SPIRV.PrimTy + colTy = SPIRV.Vector m (SPIRV.Scalar elt) + _ -> Nothing + + value :: CGMonad ID + value = fst <$> codeGen val + + fill :: SPIRV.PrimTy -> Word32 -> ID -> CGMonad (ID, SPIRV.PrimTy) + fill ty n x = compositeConstruct ty ( replicate (fromIntegral n) x ) + +-- | A component of the object a pointer points to. +data Component + = Component + { componentAccess :: OpticalOperationTree -- ^ How to access the component. + , componentTy :: SPIRV.PrimTy + } + +-- | The object a pointer points to, as a whole. +wholeObject :: Pointer -> Component +wholeObject ptr = Component [] ( SPIRV.pointee ( pointerTy ptr ) ) + +-- | The immediate subcomponents of a component. +subcomponents :: Component -> CGMonad [ Component ] +subcomponents ( Component access ty ) = case ty of + SPIRV.Vector n elt -> indexed n elt + SPIRV.Matrix m n elt -> indexed n ( SPIRV.Vector m (SPIRV.Scalar elt) ) + -- TODO: should be a loop as opposed to being fully unrolled, + -- but creating loops is unfortunately quite cumbersome + SPIRV.Array l elt -> indexed l elt + SPIRV.Struct eltTys -> sequence $ zipWith sub [0..] ( map snd eltTys ) + SPIRV.RuntimeArray {} -> throwError "codeGen: cannot store into all components of a run-time array" + _ -> pure [] + where + sub :: Word32 -> SPIRV.PrimTy -> CGMonad Component + sub i subTy = ( `Component` subTy ) <$> access `continue` [ Access Safe (CTInds [i]) ] + indexed :: Word32 -> SPIRV.PrimTy -> CGMonad [ Component ] + indexed n eltTy = sequence $ zipWith sub [0..] ( replicate (fromIntegral n) eltTy ) + +-- | Store a value into a component, applying the given operations to it. +storeInto :: CodeGen AST => Pointer -> Component -> Code b -> OpticalOperationTree -> CGMonad () +storeInto basePtr comp v ops = storeThroughAccessChain' basePtr v =<< ( componentAccess comp `continue` ops ) + +successiveStores + :: CodeGen AST + => Pointer + -> [OpticalOperationTree] + -> Codes as + -> CGMonad () +successiveStores basePtr ( tree : trees ) (ConsCode a as) = do + storeThroughAccessChain' basePtr a tree + successiveStores basePtr trees as +successiveStores _ _ _ + = pure () + +setUsingSetter' + :: CodeGen AST + => (ID, SPIRV.PrimTy) + -> Code a + -> OpticalOperationTree + -> CGMonad (ID, SPIRV.PrimTy) +setUsingSetter' _ val [] = codeGen val +setUsingSetter' base val [Access _ (CTInds is)] + = do + valID <- codeGen val + compositeInsert valID base is +-- in more complex situations, revert to using load/store +setUsingSetter' base@(baseID, _) val ops + = do + (basePtr, basePtrState) <- temporaryVariable base + unless + ( basePtrState == Fresh ) + ( storeInstruction basePtr baseID ) + -- set the temporary pointer state to "modified" + -- as we are about to store something into it + setTemporaryPointer baseID (basePtr, Modified) + storeThroughAccessChain' basePtr val ops + loadInstruction basePtr + +insertUsingSetter' + :: CodeGen AST + => ShortText + -> (ID, SPIRV.PrimTy) + -> Code a + -> OpticalOperationTree + -> CGMonad () +insertUsingSetter' varName base val ops = + assign ( _localBinding varName ) . Just =<< setUsingSetter' base val ops diff --git a/src/CodeGen/Phi.hs b/src/CodeGen/Phi.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Phi.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{-| +Module: CodeGen.Phi + +Code generation for ϕ-functions, which enables definition of variables in branches when using an SSA form. + +See also "CodeGen.CFG" which does code generation for the control flow operation themselves. +-} + +module CodeGen.Phi + ( phiInstruction, phiInstructions ) + where + +-- base +import Data.List + ( foldl1' ) +import Data.List.NonEmpty + ( NonEmpty((:|)) ) +import qualified Data.List.NonEmpty as NE + ( head, singleton, toList ) + +-- containers +import Data.Map + ( Map ) +import qualified Data.Map.Strict as Map +import qualified Data.Map.Merge.Strict as Map + +-- text-short +import Data.Text.Short + ( ShortText ) + + +-- fir +import CodeGen.Binary + ( instruction ) +import CodeGen.IDs + ( typeID ) +import CodeGen.Instruction + ( ID, Pair(Pair), Instruction(..), toArgs ) +import CodeGen.Monad + ( CGMonad, MonadFresh(fresh) ) +import qualified SPIRV.Operation as SPIRV.Op +import qualified SPIRV.PrimTy as SPIRV + +---------------------------------------------------------------------------- +-- ϕ-instructions + +conflicts :: forall k a. (Ord k, Eq a) + => ( k -> Bool ) + -> [ Map k a ] + -> Map k (NonEmpty a) +conflicts keyIsOK + = Map.filterWithKey ( \k as -> keyIsOK k && any (/= NE.head as) as ) + . foldl1' + ( Map.merge + Map.dropMissing + Map.dropMissing + ( Map.zipWithMatched (const (<>)) ) + ) + . map (fmap NE.singleton) + +-- use "Pair" for the correct "Put" instance for list of pairs +phiInstruction :: (ID, SPIRV.PrimTy) -> [ Pair ID ID ] -> CGMonad () +phiInstruction (v, ty) bdAndBlockIDs + = do + tyID <- typeID ty + instruction + Instruction + { operation = SPIRV.Op.Phi + , resTy = Just tyID + , resID = Just v + , args = toArgs bdAndBlockIDs + } + +phiInstructions :: ( ShortText -> Bool ) + -> [ ID ] + -> [ Map ShortText (ID, SPIRV.PrimTy) ] + -> CGMonad (Map ShortText ID) +phiInstructions isRelevant blocks bindings + = Map.traverseWithKey + ( \ _ idsAndTys@( (_,ty) :| _ ) -> do + let bdAndBlockIDs :: [Pair ID ID] + bdAndBlockIDs + = zipWith + (\(x_ID, _) blk -> Pair (x_ID, blk)) + (NE.toList idsAndTys) + blocks + v <- fresh + phiInstruction (v,ty) bdAndBlockIDs + pure v + ) + ( conflicts isRelevant bindings ) diff --git a/src/CodeGen/Pointers.hs b/src/CodeGen/Pointers.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/Pointers.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module: CodeGen.Pointers + +Code generation for load/store instruction using pointers. + +Values always have logical types, whereas memory can impose a layout on the types it contains. +Loading and storing converts between the two. +-} + +module CodeGen.Pointers + ( Safeness(Safe, Unsafe) + , Indices(RTInds, CTInds) + , newVariable, temporaryVariable + , accessChain + , load, loadInstruction + , store, storeInstruction + , relayout + ) where + +-- base +import Data.Word + ( Word32 ) + +-- containers +import qualified Data.Map.Strict as Map + +-- mtl +import Control.Monad.Except + ( throwError ) + +-- lens +import Control.Lens + ( use, assign, view ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( pack ) + +-- fir +import CodeGen.Binary + ( instruction ) +import CodeGen.Composite + ( accessedLaidOutTy ) +import CodeGen.IDs + ( typeID, laidOutTypeID, constID ) +import CodeGen.Instruction + ( Args(..), toArgs + , ID, TyID, Instruction(..) + , Pointer(..), Variable(..) + ) +import CodeGen.Monad + ( CGMonad + , MonadFresh(fresh) + , note + ) +import CodeGen.State + ( PointerState(Fresh) + , _interfaceBinding + , _knownConstants + , _spirvVersion + , currentFunctionContext + , addLocalVariable + , lookupTemporaryPointer, setTemporaryPointer + ) +import FIR.Prim.Types + ( SPrimTy(..), SScalarTy(..) + , PrimTy(primTySing), ScalarTy(scalarTySing) + , AConstant(AConstant) + ) +import FIR.ProgramState + ( FunctionContext(TopLevel, InEntryPoint) ) +import qualified SPIRV.Layout as SPIRV +import qualified SPIRV.Operation as SPIRV.Op +import qualified SPIRV.PrimTy as SPIRV +import qualified SPIRV.Stage as SPIRV +import qualified SPIRV.Storage as Storage +import qualified SPIRV.Version as SPIRV + +---------------------------------------------------------------------------- +-- safeness of pointer access (whether indices known to be within bounds) + +data Safeness + = Unsafe + | Safe + deriving stock ( Eq, Show ) + +instance Semigroup Safeness where + Safe <> x = x + _ <> _ = Unsafe + +data Indices + = CTInds [Word32] -- compile-time indices + | RTInds [ID] -- run-time indices + deriving stock Show + +---------------------------------------------------------------------------- +-- creating pointers + +-- | Create a new local variable of the current function, holding values of the given type. +newVariable :: SPIRV.PrimTy -> CGMonad Pointer +newVariable ty + = do + v <- fresh + ptrTyID <- typeID ( SPIRV.Pointer ptrTy ) + let ptr = Pointer v ptrTy + addLocalVariable ( Variable ptr ptrTyID ) + pure ptr + where + ptrTy :: SPIRV.PointerTy + ptrTy = SPIRV.PointerTy Storage.Function SPIRV.logical ty + +-- | Obtain a local variable holding a copy of the given value, in the current block. +temporaryVariable :: (ID, SPIRV.PrimTy) -> CGMonad (Pointer, PointerState) +temporaryVariable (baseID, baseTy) + = do + mbTemp <- lookupTemporaryPointer baseID + case mbTemp of + Just temp -> pure temp + Nothing -> do + ptr <- newVariable baseTy + storeInstruction ptr baseID + setTemporaryPointer baseID (ptr, Fresh) + pure (ptr, Fresh) + +indicesIDs :: Indices -> CGMonad [ID] +indicesIDs (CTInds ws) = traverse constID ws +indicesIDs (RTInds is) = pure is + +-- create a pointer into a composite object with a list of successive indices +accessChain :: Pointer -> Safeness -> Indices -> CGMonad Pointer +accessChain (Pointer basePtrID (SPIRV.PointerTy storage baseLayout baseTy)) safe indices + = do + is <- indicesIDs indices + (eltLayout, eltTy) <- + note ( "'accessChain': could not compute accessee type.\n\ + \base: " <> ShortText.pack (show baseTy) <> "\n\ + \indices: " <> ShortText.pack (show indices) <> "." + ) + =<< ( flip accessedLaidOutTy (baseLayout, baseTy) <$> reverseLookupIndices indices ) + let opAccessChain + = case safe of + Safe -> SPIRV.Op.InBoundsAccessChain + _ -> SPIRV.Op.AccessChain + accessPtrTy = SPIRV.PointerTy storage eltLayout eltTy + accessPtrTyID <- typeID (SPIRV.Pointer accessPtrTy) + v <- fresh + instruction + Instruction + { operation = opAccessChain + , resTy = Just accessPtrTyID + , resID = Just v + , args = Arg basePtrID + $ toArgs is + } + pure (Pointer v accessPtrTy) + +reverseLookupIndices :: Indices -> CGMonad [ Maybe Word32 ] +reverseLookupIndices (CTInds is) = pure (map Just is) +reverseLookupIndices (RTInds is) = traverse reverseConstantLookup is + +reverseConstantLookup :: ID -> CGMonad (Maybe Word32) +reverseConstantLookup c = do + lookups <- filter ( (== Just c) . resID . snd ) . Map.assocs <$> use _knownConstants + case lookups of + ( (AConstant (a :: ty), _) : _ ) + -> case primTySing @ty of + SScalar -> + case scalarTySing @ty of + SWord8 -> pure . Just $ fromIntegral a + SWord16 -> pure . Just $ fromIntegral a + SWord32 -> pure . Just $ fromIntegral a + SWord64 -> pure . Just $ fromIntegral a + SInt8 -> pure . Just $ fromIntegral a + SInt16 -> pure . Just $ fromIntegral a + SInt32 -> pure . Just $ fromIntegral a + SInt64 -> pure . Just $ fromIntegral a + _ -> pure Nothing + _ -> pure Nothing + _ -> pure Nothing + +---------------------------------------------------------------------------- +-- load/store through pointers + +-- | Load a value through the pointer of the variable with the given name. +load :: ShortText -> Pointer -> CGMonad (ID, SPIRV.PrimTy) +load loadeeName ptr@(Pointer loadeeID (SPIRV.PointerTy storage _ _)) + = do + context <- currentFunctionContext + case context of + TopLevel -> throwError "codeGen: load operation not allowed at top level" + InEntryPoint entryPointName stageInfo _ + | storage == Storage.Input + -- add this variable to the interface of the entry point + -> assign + ( _interfaceBinding entryPointName (SPIRV.modelOf stageInfo) loadeeName ) + ( Just loadeeID ) + _ -> pure () + loadInstruction ptr + +-- | Load a value through a pointer. +loadInstruction :: Pointer -> CGMonad (ID, SPIRV.PrimTy) +loadInstruction (Pointer loadeeID (SPIRV.PointerTy _ lay ty)) + = do tyID <- laidOutTypeID lay ty + v <- fresh + instruction + Instruction + { operation = SPIRV.Op.Load + , resTy = Just tyID + , resID = Just v + , args = Arg loadeeID EndArgs + } + (, ty) <$> relayout lay SPIRV.logical (v, ty) + +-- | Store a value through the pointer of the variable with the given name. +store :: ShortText -> Pointer -> ID -> CGMonad () +store storeeName ptr@(Pointer ptrID (SPIRV.PointerTy storage _ _)) storeeID + = do + context <- currentFunctionContext + case context of + TopLevel -> throwError "codeGen: store operation not allowed at top level" + InEntryPoint entryPointName stageInfo _ + | storage == Storage.Output + -- add this variable to the interface of the entry point + -> assign + ( _interfaceBinding entryPointName (SPIRV.modelOf stageInfo) storeeName ) + ( Just ptrID ) + _ -> pure () + storeInstruction ptr storeeID + +-- | Store a value through a pointer. +storeInstruction :: Pointer -> ID -> CGMonad () +storeInstruction (Pointer ptrID (SPIRV.PointerTy _ lay ty)) storeeID + = do + laidOutStoreeID <- relayout SPIRV.logical lay (storeeID, ty) + instruction + Instruction + { operation = SPIRV.Op.Store + , resTy = Nothing + , resID = Nothing + , args = Arg ptrID + $ Arg laidOutStoreeID EndArgs + } + +---------------------------------------------------------------------------- +-- converting between layouts + +-- | Convert a value of the given type from one layout to another. +relayout :: SPIRV.Layout -> SPIRV.Layout -> (ID, SPIRV.PrimTy) -> CGMonad ID +relayout from to (v, ty) = do + fromTyID <- laidOutTypeID from ty + toTyID <- laidOutTypeID to ty + if fromTyID == toTyID + then pure v + else do + ver <- view _spirvVersion + if ver >= SPIRV.Version 1 4 + then + newValue SPIRV.Op.CopyLogical toTyID ( Arg v EndArgs ) + else do + components <- case ty of + SPIRV.Array size eltTy + -> pure $ replicate ( fromIntegral size ) eltTy + SPIRV.Struct eltTys + -> pure $ map snd eltTys + _ -> throwError + ( "'relayout': cannot convert a value of type " <> ShortText.pack ( show ty ) + <> " from layout " <> ShortText.pack ( show from ) + <> " to layout " <> ShortText.pack ( show to ) <> "." + ) + let + fromComp, toComp :: SPIRV.Layout + fromComp = SPIRV.componentLayout ty from + toComp = SPIRV.componentLayout ty to + convertedComps <- + traverse + ( \ ( i, compTy ) -> do + compTyID <- laidOutTypeID fromComp compTy + comp <- newValue SPIRV.Op.CompositeExtract compTyID ( Arg v $ Arg i EndArgs ) + relayout fromComp toComp ( comp, compTy ) + ) + ( zip [ ( 0 :: Word32 ) .. ] components ) + newValue SPIRV.Op.CompositeConstruct toTyID ( toArgs convertedComps ) + + where + newValue :: SPIRV.Op.Operation -> TyID -> Args -> CGMonad ID + newValue op resTyID operands = do + u <- fresh + instruction + Instruction + { operation = op + , resTy = Just resTyID + , resID = Just u + , args = operands + } + pure u diff --git a/src/CodeGen/PrimOps.hs b/src/CodeGen/PrimOps.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/PrimOps.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module: CodeGen.PrimOps + +Code generation for primitive operations (e.g. arithmetic operations). +-} + +module CodeGen.PrimOps + ( primOp, operationInstruction ) + where + +-- base +import Control.Monad + ( when ) +import Data.Foldable + ( for_ ) +import Data.Proxy + ( Proxy ) + +-- lens +import Control.Lens + ( view ) + +-- mtl +import Control.Monad.Except + ( throwError ) + +-- text-short +import qualified Data.Text.Short as ShortText + ( pack ) + +-- fir +import CodeGen.Application + ( Application(Applied) + , traverseASTs + ) +import CodeGen.Binary + ( instruction ) +import {-# SOURCE #-} CodeGen.CodeGen + ( CodeGen(codeGenArgs), codeGen ) +import CodeGen.Debug + ( whenAsserting ) +import CodeGen.IDs + ( typeID ) +import CodeGen.Instruction + ( toArgs + , ID(ID) + , Instruction(..) + ) +import CodeGen.Monad + ( CGMonad, MonadFresh(fresh) ) +import CodeGen.State + ( _backend, _spirvVersion, requireCapabilities, requireExtensions ) +import FIR.AST + ( AST, PrimOpF(..) ) +import FIR.AST.Type + ( Nullary ) +import FIR.Prim.Op + ( PrimOp(opName) ) +import qualified SPIRV.PrimOp as SPIRV +import qualified SPIRV.PrimTy as SPIRV +import qualified SPIRV.Requirements as SPIRV +import qualified SPIRV.Operation as SPIRV + ( Operation ) +import qualified SPIRV.Version as SPIRV + +---------------------------------------------------------------------------- +-- primops + + +instance CodeGen AST => CodeGen (PrimOpF AST) where + codeGenArgs ( Applied ( PrimOpF ( _ :: Proxy a ) ( _ :: Proxy op ) ) as ) = + primOp ( opName @_ @_ @op @a ) =<< traverseASTs @Nullary codeGen as + + +primOp :: SPIRV.PrimOp -> [ (ID, SPIRV.PrimTy) ] -> CGMonad (ID, SPIRV.PrimTy) +primOp prim as = do + bk <- view _backend + let + op :: SPIRV.Operation + retTy :: SPIRV.PrimTy + (op, retTy) = SPIRV.opAndReturnType bk prim + minVer :: SPIRV.Version + minVer = SPIRV.primOpMinVersion bk prim + requireCapabilities $ SPIRV.primOpCapabilities bk prim + requireExtensions $ SPIRV.primOpExtensions bk prim + ver <- view _spirvVersion + whenAsserting . when ( ver < minVer ) . throwError $ + "primOp: operation " <> ShortText.pack ( show prim ) <> "\n\ + \requires SPIR-V version " <> ShortText.pack ( show minVer ) <> ",\n\ + \but current version is " <> ShortText.pack ( show ver ) <> "." + whenAsserting . for_ ( SPIRV.primOpUnsupported bk prim ) $ \ reason -> + throwError $ + "primOp: operation " <> ShortText.pack ( show prim ) <> " is not supported:\n" + <> ShortText.pack reason <> "." + operationInstruction op retTy ( map fst as ) + +operationInstruction :: SPIRV.Operation -> SPIRV.PrimTy -> [ ID ] -> CGMonad (ID, SPIRV.PrimTy) +operationInstruction op retTy as = case retTy of + SPIRV.Unit -> do + instruction + Instruction + { operation = op + , resTy = Nothing + , resID = Nothing + , args = toArgs as + } + pure (ID 0, retTy) -- ID should not be used + _ -> do + resTyID <- typeID retTy + v <- fresh + instruction + Instruction + { operation = op + , resTy = Just resTyID + , resID = Just v + , args = toArgs as + } + pure (v, retTy) diff --git a/src/CodeGen/RayTracing.hs b/src/CodeGen/RayTracing.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/RayTracing.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-| +Module: CodeGen.Debug + +Code generation for ray-tracing instructions. +-} + +module CodeGen.RayTracing + ( ) + where + +-- base +import Data.Proxy + ( Proxy ) +import Data.Word + ( Word32 ) + +-- lens +import Control.Lens + ( use, assign ) + +-- mtl +import Control.Monad.Except + ( throwError ) + +-- fir +import CodeGen.Application + ( ASTs(..), Application(..) + , traverseASTs + ) +import CodeGen.Binary + ( instruction ) +import {-# SOURCE #-} CodeGen.CodeGen + ( CodeGen(codeGenArgs), codeGen ) +import CodeGen.IDs + ( constID, globalID ) +import CodeGen.Instruction + ( ID(ID), Instruction(..), Args(..), Pointer(pointerID) ) +import CodeGen.Monad + ( note ) +import CodeGen.Pointers + ( newVariable ) +import CodeGen.PrimOps + ( operationInstruction ) +import CodeGen.State + ( requireCapability, requireExtension + , currentFunctionContext, _rayQuery + ) +import FIR.AST + ( AST ) +import FIR.AST.Exts + ( RayF(..) ) +import FIR.AST.Type + ( Nullary ) +import FIR.Prim.RayTracing + ( RayQuery(..), IntersectionType(..) ) +import FIR.Prim.Types + ( primTy ) +import FIR.ProgramState + ( FunctionContext(InEntryPoint) ) +import qualified SPIRV.Capability as SPIRV +import qualified SPIRV.Extension as SPIRV +import qualified SPIRV.Operation as SPIRV.Op +import qualified SPIRV.PrimTy as SPIRV +import qualified SPIRV.Stage as SPIRV + +------------------------------------------------------------------------------- + +instance CodeGen AST => CodeGen (RayF AST) where + + codeGenArgs ( Applied ( TraceRayF {..} ) NilAST ) = do + ctxt <- currentFunctionContext + case ctxt of + InEntryPoint modelName modelInfo _-> do + let + model :: SPIRV.ExecutionModel + model = SPIRV.modelOf modelInfo + accelerationStructure <- fst <$> codeGen traceRayFAccelerationStructure + rayFlags <- fst <$> codeGen traceRayFRayFlags + cullMask <- fst <$> codeGen traceRayFCullMask + sbt_offset <- fst <$> codeGen traceRayFSBTOffset + sbt_stride <- fst <$> codeGen traceRayFSBTStride + missIndex <- fst <$> codeGen traceRayFMissIndex + rayOrigin <- fst <$> codeGen traceRayFRayOrigin + rayTMin <- fst <$> codeGen traceRayFRayTMin + rayDirection <- fst <$> codeGen traceRayFRayDirection + rayTMax <- fst <$> codeGen traceRayFRayTMax + mbRayPayloadID <- fmap pointerID <$> globalID traceRayFRayPayloadName ( Just ( modelName, model ) ) + rayPayloadID <- + note + ( "codeGen: could not find RayPayload ID with name " <> traceRayFRayPayloadName ) + mbRayPayloadID + instruction + Instruction + { operation = SPIRV.Op.TraceRay + , resTy = Nothing + , resID = Nothing + , args = Arg accelerationStructure + $ Arg rayFlags + $ Arg cullMask + $ Arg sbt_offset + $ Arg sbt_stride + $ Arg missIndex + $ Arg rayOrigin + $ Arg rayTMin + $ Arg rayDirection + $ Arg rayTMax + $ Arg rayPayloadID + $ EndArgs + } + pure (ID 0, SPIRV.Unit) -- ID should not be used + _ -> throwError "codeGen: 'traceRay' outside of a ray shader" + + codeGenArgs ( Applied ( ExecuteCallableF {..} ) NilAST ) = do + ctxt <- currentFunctionContext + case ctxt of + InEntryPoint modelName modelInfo _-> do + let + model :: SPIRV.ExecutionModel + model = SPIRV.modelOf modelInfo + sbtIndex <- fst <$> codeGen executeCallableFSBTIndex + mbCallableDataID <- fmap pointerID <$> globalID executeCallableFDataName ( Just ( modelName, model ) ) + callableDataID <- + note + ( "codeGen: could not find CallableData ID with name " <> executeCallableFDataName ) + mbCallableDataID + instruction + Instruction + { operation = SPIRV.Op.ExecuteCallable + , resTy = Nothing + , resID = Nothing + , args = Arg sbtIndex + $ Arg callableDataID + $ EndArgs + } + pure (ID 0, SPIRV.Unit) -- ID should not be used + _ -> throwError "codeGen: 'executeCallable' outside of a ray shader" + + codeGenArgs ( Applied ( RayQueryInitializeF {..} ) NilAST ) = do + let + RayQuery rayQueryName = rayQueryFRayQueryName + v <- pointerID <$> newVariable SPIRV.RayQuery + assign ( _rayQuery rayQueryName ) ( Just v ) + + requireCapability SPIRV.RayQueryKHR + requireExtension SPIRV.SPV_KHR_ray_query + + accelerationStructure <- fst <$> codeGen rayQueryFAccelerationStructure + rayFlags <- fst <$> codeGen rayQueryFRayFlags + cullMask <- fst <$> codeGen rayQueryFCullMask + rayOrigin <- fst <$> codeGen rayQueryFRayOrigin + rayTMin <- fst <$> codeGen rayQueryFRayTMin + rayDirection <- fst <$> codeGen rayQueryFRayDirection + rayTMax <- fst <$> codeGen rayQueryFRayTMax + instruction + Instruction + { operation = SPIRV.Op.RayQueryInitialize + , resTy = Nothing + , resID = Nothing + , args = Arg v + $ Arg accelerationStructure + $ Arg rayFlags + $ Arg cullMask + $ Arg rayOrigin + $ Arg rayTMin + $ Arg rayDirection + $ Arg rayTMax + $ EndArgs + } + pure (ID 0, SPIRV.Unit) -- ID should not be used + + codeGenArgs ( Applied ( RayQueryPrimOpF ( _ :: Proxy a ) rayOpName ( RayQuery rayQueryName ) mbInterTy ) as ) = do + requireCapability SPIRV.RayQueryKHR + requireExtension SPIRV.SPV_KHR_ray_query + v <- note ( "'codeGen': no ray query variable named " <> rayQueryName ) + =<< use ( _rayQuery rayQueryName ) + + argIDs <- traverseASTs @Nullary ( fmap fst . codeGen ) as + case mbInterTy of + Nothing -> + operationInstruction rayOpName ( primTy @a ) ( v : argIDs ) + Just interTy -> do + interTyLit <- constID ( case interTy of { Candidate -> (0 :: Word32); Committed -> (1 :: Word32) } ) + operationInstruction rayOpName ( primTy @a ) ( v : interTyLit : argIDs ) diff --git a/src/CodeGen/State.hs b/src/CodeGen/State.hs new file mode 100644 --- /dev/null +++ b/src/CodeGen/State.hs @@ -0,0 +1,840 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +{-| +Module: CodeGen.State + +This module defines the structure of the state used by the code generation, +in two parts: + + - 'CGContext', consisting of reified type-level data provided at the start + of code generation (with a 'Control.Monad.Reader.ReaderT' transformer), + - 'CGState', consisting of state accumulated during code generation, + recording which objects have been declared and their IDs. + +This module manually provides lenses for these. Most of these could be derived +automatically, but a few of them are slightly trickier, requiring an affine traversal. + +These custom lenses also allow terse state modifications. +For instance, usage of a built-in variable simultaneously obtains an ID for the variable, +adds itself to the relevant entry point interface, and sets the necessary decorations. + +-} + +module CodeGen.State + ( -- * Code generation state + CGState(moduleState), initialState + , ModuleState(..) + , FunctionState(functionContext, localVariables) + , LexicalEnv(..) + , LoopBlockIDs(..), EarlyExit(..), LoopExit(..) + , BlockState + , PointerState(..) + + -- * Code generation context + , CGContext(..), emptyContext + + -- * Lenses + , affineTraverse + -- ** Module state + , _currentID + , _neededCapabilities, _neededCapability + , _neededExtensions, _neededExtension + , _knownExtInsts, _knownExtInst + , _knownStringLits, _knownStringLit + , _names + , _usedGlobals, _usedGlobal + , _builtinVariables, _builtinVariable + , _entryPoints, _entryPoint + , _interfaces, _interface, _interfaceBinding + , _builtin + , _decorations, _decorate + , _memberDecorations, _memberDecorate + , _knownTypes, _knownType + , _knownConstants, _knownConstant + , _knownUndefineds, _knownUndefined + , _knownBindings, _knownBinding + -- ** Lexical environment + , _localBindings, _localBinding + , _writableBindings + , _rayQueries, _rayQuery + , defineLocalBinding + , scoped + -- ** Function state + , currentFunctionContext + , withFunctionState + , addLocalVariable + -- ** Loops + , withLoopFrame + , inLoopBodyScope, innermostLoop, loopDepth + , addLoopExit + -- ** Block state + , currentBlockID + , enterBlock, leaveBlock + , lookupTemporaryPointer, setTemporaryPointer + -- ** Code generation context + , _userGlobals, _userGlobal + , _userFunctions, _userFunction + , _userEntryPoints, _userEntryPoint + , _userCapabilities, _userExtensions + , _userImages, _userImage + , _spirvVersion, _backend + , _debugging, _asserting, _emittingCode + + -- * Helper state update functions + , requireCapability, requireCapabilities + , requireExtension, requireExtensions + , addName, addMemberName + , addDecoration, addDecorations + , addMemberDecoration, addMemberDecorations + ) + where + +-- base +import Data.Maybe + ( fromMaybe ) +import Data.Word + ( Word32 ) + +-- containers +import Data.Map + ( Map ) +import qualified Data.Map as Map +import Data.Set + ( Set ) +import qualified Data.Set as Set + +-- lens +import Control.Lens + ( Lens', lens + , at + , view, set + , use, assign, modifying + ) + +-- mtl +import Control.Monad.Except + ( MonadError, throwError ) +import Control.Monad.State + ( MonadState, gets, modify' ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( unpack ) + +-- fir +import CodeGen.Instruction + ( ID(ID), TyID(tyID) + , Pointer, Variable, variableID + , Instruction + ) +import Data.Containers.Traversals + ( traverseSet_ ) +import FIR.Builtin + ( modelBuiltins, builtinDecorations ) +import FIR.Prim.Types + ( AConstant ) +import FIR.ProgramState + ( FunctionContext(TopLevel), VLFunctionContext ) -- value-level function context +import qualified SPIRV.Capability as SPIRV +import qualified SPIRV.Control as SPIRV +import qualified SPIRV.Decoration as SPIRV +import qualified SPIRV.ExecutionMode as SPIRV +import qualified SPIRV.Extension as SPIRV + ( ExtInst, Extension ) +import qualified SPIRV.Image as SPIRV +import qualified SPIRV.Layout as SPIRV + ( Layout ) +import qualified SPIRV.PrimTy as SPIRV +import qualified SPIRV.Stage as SPIRV +import qualified SPIRV.Version as SPIRV + +---------------------------------------------------------------------------- +-- * Code generation state and context + +-- | Code generation state. +-- +-- The state is split up according to the lifetime of the information it contains: +-- +-- - 'ModuleState': information about the whole SPIR-V module (types, constants, ...), +-- - 'FunctionState': information about the function currently being generated, +-- - 'LexicalEnv': the bindings in scope (restored at the end of each lexical scope), +-- - 'LoopFrame's: the loops we are currently inside, +-- - 'BlockState': information about the current basic block. +-- +-- Each of these is replaced wholesale when entering/leaving the corresponding scope, +-- using the functions 'withFunctionState', 'scoped', 'withLoopFrame', 'enterBlock' +-- and 'leaveBlock' (the constructors of 'FunctionState' and 'BlockState' are not exported). +-- Information that refers to IDs that are only valid in part of a function body +-- should be stored in the narrowest such scope, so that it can't be used where +-- it isn't valid. +-- +-- NB: the code generation for loops and functions ties a knot through this state +-- (see 'CodeGen.CFG.while' and 'CodeGen.Functions.inContext'), +-- so the fields of these records must remain lazy. +data CGState + = CGState + { moduleState :: ModuleState + , functionState :: Maybe FunctionState -- ^ @Nothing@ at the top level. + , lexicalEnv :: LexicalEnv + , loopStack :: [ LoopFrame ] -- ^ Innermost loop first. + , blockState :: BlockState + } + +-- | Information about the whole SPIR-V module being generated. +data ModuleState + = ModuleState + { + -- | Current ID number (increases by 1 each time a new ID is needed). + currentID :: ID + + -- | Capability requirements that have been declared. + , neededCapabilities :: Set SPIRV.Capability + + -- | Needed extensions. + , neededExtensions :: Set SPIRV.Extension + + -- | IDs of all used extended instruction sets. + , knownExtInsts :: Map SPIRV.ExtInst ID + + -- | IDs of constant text literals. + , knownStringLits :: Map ShortText ID + + -- | IDs which have been annotated with a name / member name. + , names :: Set (ID, Either ShortText (Word32, ShortText)) + + -- | Entry point IDs. + , entryPoints :: Map (ShortText, SPIRV.ExecutionModel) ID + + -- | Entry point interfaces, keeping track of which global variables are used. + , interfaces :: Map (ShortText, SPIRV.ExecutionModel) (Map ShortText ID) + + -- | Decorations for given types. + , decorations :: Map ID SPIRV.Decorations + + -- | Decorations for members of a given struct type. + , memberDecorations :: Map (TyID, Word32) SPIRV.Decorations + + -- | Map of all declared types, together with their layout. + -- + -- We keep the full 'Instruction' rather than just its 'TyID', + -- as the types have to be declared at the top of the SPIR-V module, + -- rather than inline with the rest of the code. + , knownTypes :: Map (SPIRV.Layout, SPIRV.PrimTy) Instruction + + -- | Map of all declared constants. + -- + -- Same comment than for 'knownTypes' regarding 'Instruction' vs 'ID'. + , knownConstants :: Map AConstant Instruction + + -- | Map of all types who have a corresponding "Undefined" instruction. + , knownUndefineds :: Map SPIRV.PrimTy (ID, TyID) + + -- | Which user-defined global variables have been used? + , usedGlobals :: Map ShortText Variable + + -- | Built-in variables that have been used (each entry point has its own), with their names. + , builtinVariables :: Map ID (ShortText, Variable) + + -- | Top-level bindings available, such as top-level functions. + , knownBindings :: Map ShortText (ID, SPIRV.PrimTy) + } + +-- | Information about the function currently being generated. +data FunctionState + = FunctionState + { -- | Whether we are in a function or an entry point. + functionContext :: VLFunctionContext + + -- | Local variables of the function. + -- + -- These are declared at the start of the function body. + , localVariables :: Map ID Variable + } + +-- | The bindings in scope. +data LexicalEnv + = LexicalEnv + { -- | Variables declared by the user in the program. + localBindings :: Map ShortText (ID, SPIRV.PrimTy) + + -- | Which of the local bindings can be modified. + -- + -- This doesn't include bindings that are pointers (e.g. a mutable array). + , writableBindings :: Set ShortText + + -- | IDs of locally declared ray query variables. + , rayQueries :: Map ShortText ID + } + +-- | Information about a loop we are currently inside of. +data LoopFrame + = LoopFrame + { loopBlockIDs :: LoopBlockIDs + + -- | Whether we are in the body of this loop (as opposed to its condition). + , inLoopBody :: Bool + + -- | The early exits which branch to the continue or merge block of this + -- loop, keyed by the ID of the block in which the early exit occurred, + -- together with the values of the bindings at that point. + , loopExits :: Map ID ( LoopExit, Map ShortText (ID, SPIRV.PrimTy) ) + } + +-- | Information about the current basic block. +data BlockState + = BlockState + { -- | ID of the current block, or @Nothing@ if there is no current block. + currentBlock :: Maybe ID + + -- | Temporary pointers holding copies of values, keyed by the ID of the value. + , temporaryPointers :: Map ID (Pointer, PointerState) + } + +data PointerState + = Fresh + | Modified + deriving stock ( Eq, Show ) + +data LoopBlockIDs + = LoopBlockIDs + { continueBlockID :: !ID + , mergeBlockID :: !ID + } + deriving stock ( Show, Eq, Ord ) + +-- | An early exit from loops ('break' or 'breakContinue'). +data EarlyExit + -- | Break out of the given number of loops (at least 1). + = Break Word32 + -- | Break out of the given number of loops, and then continue + -- to the next iteration of the enclosing loop. + | BreakContinue Word32 + deriving stock ( Show, Eq, Ord ) + +-- | How an early exit leaves the innermost loop. +-- +-- In structured control flow, it is only possible to branch to the continue or merge block +-- of the innermost loop. Exiting several loops at once thus amounts to exiting the innermost +-- loop, and then performing the remaining early exit from its merge block. +data LoopExit + -- | Continue to the next iteration of the loop. + = ContinueLoop + -- | Exit the loop, and then perform the given early exit from the enclosing loops (if any). + | ExitLoop ( Maybe EarlyExit ) + deriving stock ( Show, Eq, Ord ) + +initialState :: CGContext -> CGState +initialState CGContext { userCapabilities, userExtensions } + = CGState + { moduleState = + ModuleState + { currentID = ID 1 + , neededCapabilities = userCapabilities + , neededExtensions = userExtensions + , knownExtInsts = Map.empty + , knownStringLits = Map.empty + , names = Set.empty + , entryPoints = Map.empty + , interfaces = Map.empty + , decorations = Map.empty + , memberDecorations = Map.empty + , knownTypes = Map.empty + , knownConstants = Map.empty + , knownUndefineds = Map.empty + , usedGlobals = Map.empty + , builtinVariables = Map.empty + , knownBindings = Map.empty + } + , functionState = Nothing + , lexicalEnv = + LexicalEnv + { localBindings = Map.empty + , writableBindings = Set.empty + , rayQueries = Map.empty + } + , loopStack = [] + , blockState = noBlock + } + +-- | Block state when there is no current block. +noBlock :: BlockState +noBlock = BlockState { currentBlock = Nothing, temporaryPointers = Map.empty } + +-- | Code generation context. +-- +-- Consists of information provided at the start of code generation, +-- as provided by the user-provided type annotations of +-- top-level functions, entry points and input/output variables. +data CGContext + = CGContext + { -- | User defined inputs/outputs (not builtins). + userGlobals + :: Map ShortText (SPIRV.PointerTy, SPIRV.Decorations) + + -- | User defined functions (not entry points). + , userFunctions + :: Map ShortText SPIRV.FunctionControl + + -- | User defined entry points. + , userEntryPoints + :: Map (ShortText, SPIRV.ExecutionModel) SPIRV.ExecutionModes + + -- | Capabilities that are required (computed from user definitions). + , userCapabilities + :: Set SPIRV.Capability + + -- | Extensions that are required (computed from user definitions). + , userExtensions + :: Set SPIRV.Extension + + -- | User defined images. + , userImages + :: Map ShortText SPIRV.Image + + -- | SPIR-V version to use. + , spirvVersion :: SPIRV.Version + + -- | SPIR-V backend to use (Vulkan or OpenCL). + , backend :: SPIRV.Backend + + -- | Whether to add extra source information in the generated SPIR-V assembly. + , debugging :: Bool + + -- | Whether to enable assertions. + , asserting :: Bool + + -- | Whether to emit assembly code. + , emittingCode :: Bool + } + deriving stock Show + +emptyContext :: CGContext +emptyContext + = CGContext + { userGlobals = Map.empty + , userFunctions = Map.empty + , userEntryPoints = Map.empty + , userCapabilities = Set.empty + , userExtensions = Set.empty + , userImages = Map.empty + , spirvVersion = SPIRV.Version 1 5 + , backend = SPIRV.Vulkan + , debugging = False + , asserting = False + , emittingCode = True + } + +---------------------------------------------------------------------------- +-- * Lenses + +-- | Affine traversal relative to 'Maybe'. +-- +-- Useful function to deal with nested data structures +-- such as @Map a (Map b c)@ +affineTraverse :: (Monoid a, Functor f) => (a -> f b) -> (Maybe a -> f (Maybe b)) +affineTraverse f Nothing = fmap Just (f mempty) +affineTraverse f (Just a) = fmap Just (f a) + +---------------------------------------------------------------------------- +-- ** Module state + +-- Internal +_moduleState :: Lens' CGState ModuleState +_moduleState = lens moduleState ( \s v -> s { moduleState = v } ) + +_currentID :: Lens' CGState ID +_currentID = _moduleState . lens currentID ( \s v -> s { currentID = v } ) + +_neededCapabilities :: Lens' CGState (Set SPIRV.Capability) +_neededCapabilities = _moduleState . lens neededCapabilities ( \s v -> s { neededCapabilities = v } ) + +_neededCapability :: SPIRV.Capability -> Lens' CGState (Maybe ()) +_neededCapability capability = _neededCapabilities . at capability + +_neededExtensions :: Lens' CGState (Set SPIRV.Extension) +_neededExtensions = _moduleState . lens neededExtensions ( \s v -> s { neededExtensions = v } ) + +_neededExtension :: SPIRV.Extension -> Lens' CGState (Maybe ()) +_neededExtension extension = _neededExtensions . at extension + +_knownExtInsts :: Lens' CGState (Map SPIRV.ExtInst ID) +_knownExtInsts = _moduleState . lens knownExtInsts ( \s v -> s { knownExtInsts = v } ) + +_knownExtInst :: SPIRV.ExtInst -> Lens' CGState (Maybe ID) +_knownExtInst ext = _knownExtInsts . at ext + +_knownStringLits :: Lens' CGState (Map ShortText ID) +_knownStringLits = _moduleState . lens knownStringLits ( \s v -> s { knownStringLits = v } ) + +_knownStringLit :: ShortText -> Lens' CGState (Maybe ID) +_knownStringLit lit = _knownStringLits . at lit + +_names :: Lens' CGState ( Set (ID, Either ShortText (Word32, ShortText)) ) +_names = _moduleState . lens names ( \s v -> s { names = v } ) + +_usedGlobals :: Lens' CGState (Map ShortText Variable) +_usedGlobals = _moduleState . lens usedGlobals ( \s v -> s { usedGlobals = v } ) + +_usedGlobal :: ShortText -> Lens' CGState (Maybe Variable) +_usedGlobal name = _usedGlobals . at name + +_builtinVariables :: Lens' CGState (Map ID (ShortText, Variable)) +_builtinVariables = _moduleState . lens builtinVariables ( \s v -> s { builtinVariables = v } ) + +_builtinVariable :: ID -> Lens' CGState (Maybe (ShortText, Variable)) +_builtinVariable v = _builtinVariables . at v + +_entryPoints :: Lens' CGState (Map (ShortText, SPIRV.ExecutionModel) ID) +_entryPoints = _moduleState . lens entryPoints ( \s v -> s { entryPoints = v } ) + +_entryPoint :: ShortText -> SPIRV.ExecutionModel -> Lens' CGState (Maybe ID) +_entryPoint name stage = _entryPoints . at (name, stage) + +_interfaces :: Lens' CGState (Map (ShortText, SPIRV.ExecutionModel) (Map ShortText ID)) +_interfaces = _moduleState . lens interfaces ( \s v -> s { interfaces = v } ) + +_interface :: ShortText -> SPIRV.ExecutionModel -> Lens' CGState (Maybe (Map ShortText ID)) +_interface stageName stage = _interfaces . at (stageName, stage) + +_interfaceBinding :: ShortText -> SPIRV.ExecutionModel -> ShortText -> Lens' CGState (Maybe ID) +_interfaceBinding stageName stage varName + = _interface stageName stage + . affineTraverse + . at varName + +-- | The ID of a built-in variable, for a given entry point. +-- +-- Setting this adds the built-in variable to the interface of the entry point, +-- and sets the necessary decorations. +_builtin :: ShortText -> SPIRV.ExecutionInfo Word32 stage -> ShortText -> Lens' CGState (Maybe ID) +_builtin stageName executionInfo builtinName + = lens + ( view _interfaceBuiltin ) + ( \s mb_i -> case mb_i of + Nothing -> s + Just i -> set _interfaceBuiltin ( Just i ) + . set ( _decorate i ) ( Just decs ) + $ s + ) + where executionModel :: SPIRV.ExecutionModel + executionModel = SPIRV.modelOf executionInfo + + _interfaceBuiltin :: Lens' CGState (Maybe ID) + _interfaceBuiltin = _interfaceBinding stageName executionModel builtinName + + decs :: SPIRV.Decorations + decs = builtinDecorations executionModel builtinName builtinTy + + builtinTy :: SPIRV.PointerTy + builtinTy = + fromMaybe + ( error + ( "_builtin: builtin with name " ++ ShortText.unpack builtinName ++ " cannot be found,\n\ + \among builtins for " ++ show executionModel ++ " named " ++ ShortText.unpack stageName + ) + ) + ( lookup builtinName $ modelBuiltins executionInfo ) + + +_decorations :: Lens' CGState (Map ID SPIRV.Decorations) +_decorations = _moduleState . lens decorations ( \s v -> s { decorations = v } ) + +_decorate :: ID -> Lens' CGState (Maybe SPIRV.Decorations) +_decorate bindingID = _decorations . at bindingID + +_memberDecorations :: Lens' CGState ( Map (TyID, Word32) SPIRV.Decorations ) +_memberDecorations = _moduleState . lens memberDecorations ( \s v -> s { memberDecorations = v } ) + +_memberDecorate :: TyID -> Word32 -> Lens' CGState ( Maybe SPIRV.Decorations ) +_memberDecorate bindingTyID index + = _memberDecorations + . at (bindingTyID, index) + +_knownTypes :: Lens' CGState (Map (SPIRV.Layout, SPIRV.PrimTy) Instruction) +_knownTypes = _moduleState . lens knownTypes ( \s v -> s { knownTypes = v } ) + +_knownType :: SPIRV.Layout -> SPIRV.PrimTy -> Lens' CGState (Maybe Instruction) +_knownType lay primTy = _knownTypes . at (lay, primTy) + +_knownConstants :: Lens' CGState (Map AConstant Instruction) +_knownConstants = _moduleState . lens knownConstants ( \s v -> s { knownConstants = v } ) + +_knownConstant :: AConstant -> Lens' CGState (Maybe Instruction) +_knownConstant constant = _knownConstants . at constant + +_knownUndefineds :: Lens' CGState (Map SPIRV.PrimTy (ID, TyID)) +_knownUndefineds = _moduleState . lens knownUndefineds ( \s v -> s { knownUndefineds = v } ) + +_knownUndefined :: SPIRV.PrimTy -> Lens' CGState (Maybe (ID,TyID)) +_knownUndefined primTy = _knownUndefineds . at primTy + +_knownBindings :: Lens' CGState (Map ShortText (ID, SPIRV.PrimTy)) +_knownBindings = _moduleState . lens knownBindings ( \s v -> s { knownBindings = v } ) + +_knownBinding :: ShortText -> Lens' CGState (Maybe (ID, SPIRV.PrimTy)) +_knownBinding binding = _knownBindings . at binding + +---------------------------------------------------------------------------- +-- ** Lexical environment + +-- Internal +_lexicalEnv :: Lens' CGState LexicalEnv +_lexicalEnv = lens lexicalEnv ( \s v -> s { lexicalEnv = v } ) + +_localBindings :: Lens' CGState (Map ShortText (ID, SPIRV.PrimTy)) +_localBindings = _lexicalEnv . lens localBindings ( \s v -> s { localBindings = v } ) + +_localBinding :: ShortText -> Lens' CGState (Maybe (ID, SPIRV.PrimTy)) +_localBinding binding = _localBindings . at binding + +_writableBindings :: Lens' CGState (Set ShortText) +_writableBindings = _lexicalEnv . lens writableBindings ( \s v -> s { writableBindings = v } ) + +_rayQueries :: Lens' CGState (Map ShortText ID) +_rayQueries = _lexicalEnv . lens rayQueries ( \s v -> s { rayQueries = v } ) + +_rayQuery :: ShortText -> Lens' CGState (Maybe ID) +_rayQuery v = _rayQueries . at v + +-- | Define a local binding, recording whether it can be modified. +defineLocalBinding :: MonadState CGState m => ShortText -> (ID, SPIRV.PrimTy) -> Bool -> m () +defineLocalBinding name bd writable = do + assign ( _localBinding name ) ( Just bd ) + modifying _writableBindings ( if writable then Set.insert name else Set.delete name ) + +-- | Run an action in a new lexical scope; the previous lexical environment is +-- restored afterwards. +-- +-- Returns the lexical environment at the end of the scope +scoped :: MonadState CGState m => m a -> m ( a, LexicalEnv ) +scoped action = do + envBefore <- use _lexicalEnv + a <- action + envAfter <- use _lexicalEnv + assign _lexicalEnv envBefore + pure ( a, envAfter ) + +---------------------------------------------------------------------------- +-- ** Function state + +-- | The current function context. +currentFunctionContext :: MonadState CGState m => m VLFunctionContext +currentFunctionContext = gets ( maybe TopLevel functionContext . functionState ) + +-- | Run an action with a fresh function state, returning the function state +-- at the end. +withFunctionState :: MonadState CGState m => VLFunctionContext -> m a -> m ( a, FunctionState ) +withFunctionState context action = do + before <- gets functionState + modify' \ s -> s { functionState = Just ( FunctionState { functionContext = context, localVariables = Map.empty } ) } + a <- action + after <- gets functionState + modify' \ s -> s { functionState = before } + pure ( a, fromMaybe ( error "withFunctionState: function state disappeared" ) after ) + +-- | Record a local variable of the current function. +addLocalVariable :: ( MonadState CGState m, MonadError ShortText m ) => Variable -> m () +addLocalVariable var = do + mbFunState <- gets functionState + case mbFunState of + Nothing -> + throwError "codeGen: cannot declare a local variable outside of a function" + Just funState -> + modify' \ s -> s { functionState = Just funState { localVariables = Map.insert ( variableID var ) var ( localVariables funState ) } } + +---------------------------------------------------------------------------- +-- ** Loops + +-- | Run an action (code generation for a loop) inside a new loop frame, +-- returning the early exits that branch to the continue or merge block of this loop. +withLoopFrame + :: MonadState CGState m + => LoopBlockIDs -> m a -> m ( a, Map ID ( LoopExit, Map ShortText (ID, SPIRV.PrimTy) ) ) +withLoopFrame ids action = do + modify' \ s -> s { loopStack = LoopFrame { loopBlockIDs = ids, inLoopBody = False, loopExits = Map.empty } : loopStack s } + a <- action + frames <- gets loopStack + case frames of + frame : outer -> do + modify' \ s -> s { loopStack = outer } + pure ( a, loopExits frame ) + [] -> error "withLoopFrame: loop frame disappeared" + +-- | Run an action (code generation for the body of the innermost loop) in the body of the loop. +inLoopBodyScope :: MonadState CGState m => m a -> m a +inLoopBodyScope action = do + setInLoopBody True + a <- action + setInLoopBody False + pure a + +setInLoopBody :: MonadState CGState m => Bool -> m () +setInLoopBody b = modify' \ s -> case loopStack s of + frame : outer -> s { loopStack = frame { inLoopBody = b } : outer } + [] -> s + +-- | The innermost loop, and whether we are in its body. +innermostLoop :: MonadState CGState m => m ( Maybe ( LoopBlockIDs, Bool ) ) +innermostLoop = gets \ s -> case loopStack s of + frame : _ -> Just ( loopBlockIDs frame, inLoopBody frame ) + [] -> Nothing + +-- | Number of loops whose body we are in. +loopDepth :: MonadState CGState m => m Int +loopDepth = gets ( length . filter inLoopBody . loopStack ) + +-- | Record an early exit from the innermost loop. +addLoopExit + :: ( MonadState CGState m, MonadError ShortText m ) + => ID -> LoopExit -> Map ShortText (ID, SPIRV.PrimTy) -> m () +addLoopExit blockID loopExit bindings = do + frames <- gets loopStack + case frames of + frame : outer -> + modify' \ s -> s { loopStack = frame { loopExits = Map.insert blockID ( loopExit, bindings ) ( loopExits frame ) } : outer } + [] -> throwError "codeGen: early exit outside of a loop" + +---------------------------------------------------------------------------- +-- ** Block state + +-- | The ID of the current block, if any. +-- +-- When there is no current block, the code being generated is unreachable. +currentBlockID :: MonadState CGState m => m ( Maybe ID ) +currentBlockID = gets ( currentBlock . blockState ) + +-- | Start a new block, with an empty block state. +-- +-- NB: this doesn't emit the label instruction (see 'CodeGen.CFG.block'). +enterBlock :: MonadState CGState m => ID -> m () +enterBlock blockID = modify' \ s -> s { blockState = noBlock { currentBlock = Just blockID } } + +-- | End the current block (e.g. after a terminator instruction). +leaveBlock :: MonadState CGState m => m () +leaveBlock = modify' \ s -> s { blockState = noBlock } + +lookupTemporaryPointer :: MonadState CGState m => ID -> m ( Maybe (Pointer, PointerState) ) +lookupTemporaryPointer v = gets ( Map.lookup v . temporaryPointers . blockState ) + +setTemporaryPointer :: MonadState CGState m => ID -> (Pointer, PointerState) -> m () +setTemporaryPointer v ptr = + modify' \ s -> s { blockState = ( blockState s ) { temporaryPointers = Map.insert v ptr ( temporaryPointers ( blockState s ) ) } } + +---------------------------------------------------------------------------- +-- ** Code generation context + +_userGlobals + :: Lens' CGContext + ( Map ShortText + ( SPIRV.PointerTy + , SPIRV.Decorations + ) + ) +_userGlobals = lens userGlobals ( \c v -> c { userGlobals = v } ) + +_userGlobal + :: ShortText + -> Lens' CGContext + ( Maybe + ( SPIRV.PointerTy + , SPIRV.Decorations + ) + ) +_userGlobal global = _userGlobals . at global + +_userFunctions :: Lens' CGContext ( Map ShortText SPIRV.FunctionControl ) +_userFunctions = lens userFunctions ( \c v -> c { userFunctions = v } ) + +_userFunction :: ShortText -> Lens' CGContext ( Maybe SPIRV.FunctionControl ) +_userFunction function = _userFunctions . at function + +_userEntryPoints :: Lens' CGContext ( Map (ShortText, SPIRV.ExecutionModel) SPIRV.ExecutionModes ) +_userEntryPoints = lens userEntryPoints ( \c v -> c { userEntryPoints = v } ) + +_userEntryPoint :: ShortText -> SPIRV.ExecutionModel -> Lens' CGContext ( Maybe SPIRV.ExecutionModes ) +_userEntryPoint name stage = _userEntryPoints . at (name, stage) + +_userCapabilities :: Lens' CGContext (Set SPIRV.Capability) +_userCapabilities = lens userCapabilities ( \c v -> c { userCapabilities = v } ) + +_userExtensions :: Lens' CGContext (Set SPIRV.Extension) +_userExtensions = lens userExtensions ( \c v -> c { userExtensions = v } ) + +_userImages :: Lens' CGContext ( Map ShortText SPIRV.Image ) +_userImages = lens userImages ( \c v -> c { userImages = v } ) + +_userImage :: ShortText -> Lens' CGContext ( Maybe SPIRV.Image ) +_userImage image = _userImages . at image + +_spirvVersion :: Lens' CGContext SPIRV.Version +_spirvVersion = lens spirvVersion ( \c v -> c { spirvVersion = v } ) + +_backend :: Lens' CGContext SPIRV.Backend +_backend = lens backend ( \c v -> c { backend = v } ) + +_debugging :: Lens' CGContext Bool +_debugging = lens debugging ( \c v -> c { debugging = v } ) + +_asserting :: Lens' CGContext Bool +_asserting = lens asserting ( \c v -> c { asserting = v } ) + +_emittingCode :: Lens' CGContext Bool +_emittingCode = lens emittingCode ( \c v -> c { emittingCode = v } ) + +----------------------------------------------------------------------------- +-- * Helper state update functions + +requireCapability :: MonadState CGState m => SPIRV.Capability -> m () +requireCapability cap = assign ( _neededCapability cap ) (Just ()) + +requireCapabilities :: MonadState CGState m => Set SPIRV.Capability -> m () +requireCapabilities = traverseSet_ requireCapability + +requireExtension :: MonadState CGState m => SPIRV.Extension -> m () +requireExtension ext = assign ( _neededExtension ext ) (Just ()) + +requireExtensions :: MonadState CGState m => Set SPIRV.Extension -> m () +requireExtensions = traverseSet_ requireExtension + +addName :: MonadState CGState m + => ID -> ShortText -> m () +addName bdID name + = modifying _names + ( Set.insert (bdID, Left name) ) + +addMemberName :: MonadState CGState m + => TyID -> Word32 -> ShortText -> m () +addMemberName structTyID index name + = modifying _names + ( Set.insert (tyID structTyID, Right (index,name)) ) + +addDecoration :: MonadState CGState m + => ID -> SPIRV.Decoration Word32 -> m () +addDecoration bdID dec + = modifying ( _decorate bdID ) + ( Just . maybe (Set.singleton dec) (Set.insert dec) ) + +addDecorations :: MonadState CGState m + => ID -> SPIRV.Decorations -> m () +addDecorations bdID decs + = modifying ( _decorate bdID ) + ( Just . maybe decs (Set.union decs) ) + +addMemberDecoration :: MonadState CGState m + => TyID -> Word32 -> SPIRV.Decoration Word32 -> m () +addMemberDecoration structTyID index dec + = modifying ( _memberDecorate structTyID index ) + ( Just . maybe (Set.singleton dec) (Set.insert dec) ) + +addMemberDecorations :: MonadState CGState m + => TyID -> Word32 -> SPIRV.Decorations -> m () +addMemberDecorations structTyID index decs + = modifying ( _memberDecorate structTyID index ) + ( Just . maybe decs (Set.union decs) ) diff --git a/src/Control/Arrow/Strength.hs b/src/Control/Arrow/Strength.hs new file mode 100644 --- /dev/null +++ b/src/Control/Arrow/Strength.hs @@ -0,0 +1,35 @@ +{-| +Module: Control.Arrow.Strength + +Some useful functions relating arrows and functors via functor strength. +-} + +module Control.Arrow.Strength where + +-- base +import Control.Arrow + ( Arrow(first,second,(&&&)), (>>^) ) + +--------------------------------------------------- +-- Strengths. + +rightStrength :: Functor f => d -> f c -> f (d,c) +rightStrength = fmap . (,) + +leftStrength :: Functor f => f b -> d -> f (b,d) +leftStrength = flip (fmap . flip (,)) + +strong :: Functor f => f (a,b) -> (f a, f b) +strong = fmap fst &&& fmap snd + +--------------------------------------------------- +-- Functor f => Strong (Star f) +-- (Strong p, Strong q) => Strong (ProCompose p q) + +firstF :: (Arrow a, Functor f) + => a b (f c) -> a (b, d) (f (c, d)) +firstF = (>>^ uncurry leftStrength) . first + +secondF :: (Arrow a, Functor f) + => a b (f c) -> a (d, b) (f (d, c)) +secondF = (>>^ uncurry rightStrength) . second diff --git a/src/Control/Monad/Indexed.hs b/src/Control/Monad/Indexed.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Indexed.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: Control.Monad.Indexed + +Indexed functors and monads. + +This module includes two versions, as described in Conor McBride's paper +/Kleisli Arrows of Outrageous Fortune/. + +McBride-style indexed monads are usually written with an @ix@ /suffix/, +whereas AtKey-style indexed monads are usually written with an @ix@ /prefix/. + +-} + +module Control.Monad.Indexed + ( -- * McBride-style indexed monads + FunctorIx(fmapIx), MonadIx(returnIx, extendIx), MonadIxFail(fail) + -- ** Identity indexed monad + , Id(Id, runId) + -- ** Codensity transformation + , Codensity(Codensity, runCodensity) + + -- * Atkey-style indexed monads + -- ** Representing Atkey indexed monads using the /At Key/ trick + , (:=)(AtKey), atKey, withKey + -- ** Atkey functor operations + , ixFmap, (<<$>>), (<<$), ($>>), (<<&>>) + -- ** Atkey applicative operations + , IxApplicative((<<*>>)) + , (*>>), (<<*), ixLiftA2, ixLiftA3, ixLiftA4 + + -- ** Foldable/traversable operations + , IxF(..) + , ixTraverse, ixFor + , ixTraverse_, ixFor_ + + -- * Rebindable syntax for @do@ notation + , (>>=), (=<<), (>>), (<<), return, pure, ixPure, + + ) + where + +-- base +import Data.Coerce + ( coerce ) +import Data.Foldable + ( traverse_ ) +import Data.Kind + ( Type ) +import Prelude + hiding ( Functor(..), Applicative(..), Monad(..), (=<<) ) +import qualified Prelude + +------------------------------------------------ +-- indexed monads (à la McBride) + +class FunctorIx ( f :: (k -> Type) -> (k -> Type) ) where + fmapIx :: ( forall ix. p ix -> q ix ) + -> ( forall ix. f p ix -> f q ix ) + +class FunctorIx m => MonadIx m where + returnIx :: p ix -> m p ix + -- | Demonic bind. + extendIx :: ( forall ix. p ix -> m q ix ) + -> ( forall ix. m p ix -> m q ix ) + +class MonadIx m => MonadIxFail m where + fail :: String -> m (a := j) i + +------------------------------------------------------------ +-- identity indexed monad + +newtype Id p i = Id { runId :: p i } + +instance FunctorIx Id where + fmapIx f (Id a) = Id (f a) + +instance MonadIx Id where + extendIx f (Id a) = f a + returnIx = Id + +------------------------------------------------------------ +-- codensity transformation + +-- | Demonic codensity transformation. +-- +-- For any @(f :: Type -> Type)@, +-- @Codensity f@ is guaranteed to be an indexed monad. +-- +-- This is especially useful for manipulating ASTs. +newtype Codensity (f :: t -> Type) (p :: ix -> Type) (i :: ix) where + Codensity + :: { runCodensity + :: forall (q :: ix -> t) + . ( ( forall (j :: ix). p j -> f (q j) ) -> f (q i) ) + } + -> Codensity f p i + + +instance FunctorIx (Codensity f) where + fmapIx :: ( forall ix. p ix -> q ix ) + -> ( forall ix. Codensity f p ix -> Codensity f q ix ) + fmapIx f (Codensity m) = Codensity ( \k -> m ( k . f ) ) + +instance MonadIx (Codensity f) where + returnIx :: p i -> Codensity f p i + returnIx a = Codensity ( \k -> k a ) + + extendIx :: ( forall ix. p ix -> Codensity f q ix ) + -> ( forall ix. Codensity f p ix -> Codensity f q ix ) + extendIx f (Codensity ma) = Codensity ( \k -> ma ( \a -> runCodensity (f a) k ) ) + +------------------------------------------------ +-- Atkey indexing + +-- | The /At Key/ datatype allows us to express Atkey-style indexed monads +-- in terms of McBride-style indexed monads. +data (:=) :: Type -> i -> (i -> Type) where + AtKey :: a -> (a := i) i + +atKey :: (a := j) i -> a +atKey (AtKey a) = a + +instance Show a => Show ( (a := i) j ) where + show (AtKey a) = "AtKey " ++ show a + +withKey :: (a -> b) -> (a := i) j -> (b := i) j +withKey f (AtKey a) = AtKey (f a) + +------------------------------------------------------------ +-- useful operators & functions for AtKey-style indexing + +ixFmap :: forall m i j a b. FunctorIx m => (a -> b) -> m (a := j) i -> m (b := j) i +ixFmap f = fmapIx ( withKey f ) + +infixl 4 <<$>> +infixl 4 <<$ +infixl 4 $>> +infixl 1 <<&>> + +(<<$>>) :: FunctorIx f => (a -> b) -> f (a := j) i -> f (b := j) i +(<<$>>) = ixFmap +(<<$) :: FunctorIx f => a -> f (b := j) i -> f (a := j) i +(<<$) = ixFmap . const +($>>) :: FunctorIx f => f (a := j) i -> b -> f (b := j) i +($>>) = flip (<<$) +(<<&>>) :: FunctorIx f => f (a := j) i -> (a -> b) -> f (b := j) i +(<<&>>) = flip ixFmap + +infixl 4 <<*>> +class FunctorIx f => IxApplicative f where + (<<*>>) :: f ((a -> b) := j) i -> (f (a := k) j -> f (b := k) i) + ixPure :: a -> f (a := i) i + +instance (FunctorIx m, MonadIx m) => IxApplicative m where + mf <<*>> ma = mf >>= (<<$>> ma) + ixPure = returnIx . AtKey + +infixl 4 *>> +infixl 4 <<* + +(*>>) :: IxApplicative f => f (a := j) i -> f (b := k) j -> f (b := k) i +fa *>> fb = (id <<$ fa) <<*>> fb +(<<*) :: IxApplicative f => f (a := j) i -> f (b := k) j -> f (a := k) i +fa <<* fb = (const <<$>> fa) <<*>> fb + +ixLiftA2 :: IxApplicative f + => (a -> b -> c) + -> f (a := j) i -> f (b := k) j -> f (c := k) i +ixLiftA2 f a b = f <<$>> a <<*>> b + +ixLiftA3 :: IxApplicative f + => (a -> b -> c -> d) + -> f (a := j) i -> f (b := k) j -> f (c := l) k -> f (d := l) i +ixLiftA3 f a b c = f <<$>> a <<*>> b <<*>> c + +ixLiftA4 :: IxApplicative f + => (a -> b -> c -> d -> e) + -> f (a := j) i -> f (b := k) j -> f (c := l) k -> f (d := m) l -> f (e := m) i +ixLiftA4 f a b c d = f <<$>> a <<*>> b <<*>> c <<*>> d + +------------------------------------------------ +-- foldable/traversable + +-- newtype to put type variable last +newtype IxF f i j a = IxF { ixF :: f (a := j) i } + +instance FunctorIx f => Prelude.Functor (IxF f i j) where + fmap :: forall a b. (a -> b) -> (IxF f i j a -> IxF f i j b) + fmap = coerce ( ixFmap @f @i @j @a @b) +instance IxApplicative f => Prelude.Applicative (IxF f i i) where + pure :: forall a. a -> IxF f i i a + pure = coerce ( ixPure @f @a @i ) + (<*>) :: forall a b. IxF f i i (a -> b) -> (IxF f i i a -> IxF f i i b) + (<*>) = coerce ( (<<*>>) @f @a @b @i @i @i ) + +ixTraverse + :: forall f t a b i. + (Prelude.Traversable t, IxApplicative f) + => (a -> f (b := i) i) -> t a -> f (t b := i) i +ixTraverse f = coerce ( traverse @t (IxF . f) ) + +ixFor + :: forall f t a b i. + (Prelude.Traversable t, IxApplicative f) + => t a -> (a -> f (b := i) i) -> f (t b := i) i +ixFor = flip ixTraverse + +ixTraverse_ + :: forall f t a b i. + (Prelude.Foldable t, IxApplicative f) + => (a -> f (b := i) i) -> t a -> f (() := i) i +ixTraverse_ f = coerce ( traverse_ @t (IxF . f) ) + +ixFor_ + :: (Prelude.Foldable t, IxApplicative f) + => t a -> (a -> f (b := i) i) -> f (() := i) i +ixFor_ = flip ixTraverse_ + +------------------------------------------------ +-- rebindable syntax + +infixl 1 >>= +-- | Angelic bind. +(>>=) :: MonadIx m => m (a := j) i -> (a -> m q j) -> m q i +c >>= f = extendIx ( \ (AtKey a) -> f a ) c + +infixl 1 >> +(>>) :: MonadIx m => m (a := j) i -> m q j -> m q i +ma >> mb = ma >>= const mb + +infixr 1 << +(<<) :: MonadIx m => m q j -> m (a := j) i -> m q i +(<<) = flip (>>) + +infixr 1 =<< +(=<<) :: MonadIx m => (a -> m q j) -> m (a := j) i -> m q i +(=<<) = flip (>>=) + +return, pure :: MonadIx m => a -> m (a := i) i +return = returnIx . AtKey +pure = returnIx . AtKey diff --git a/src/Control/Type/Optic.hs b/src/Control/Type/Optic.hs new file mode 100644 --- /dev/null +++ b/src/Control/Type/Optic.hs @@ -0,0 +1,971 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Control.Type.Optic + +This module provides __type-level optics__, in the form of /getters/ and /setters/. + +@Optic is s a@ describes the kind of an optic: + + * @is@ is a list of the types of the indices which have to be provided at run-time. + When all accessor information is known at compile-time, this is the empty list @'[]@. + * @s@ is the type of the container, + * @a@ is the type of the component which is being focused on inside the container. + +For instance, an optic which focuses on a single component of a vector of size 4 with a compile-time index +has kind @Optic '[] (V 4 a) a@. + + +The basic optics provided, to focus into an object of type @s@ onto a subobject of type @a@, are: + + * @AnIndex ix :: Optic '[ix] s a@: focus via a run-time index of type @ix@, + * @Index i :: Optic '[] s a@: focus via the compile-time index @i :: Nat@, + * @Name k :: Optic '[] s a@: focus via the compile-time literal @k :: Symbol@. + +The compile-time nature of 'Index' and 'Name' means that we can type-check their usage +to prevent focusing on a non-existent field (such as an out-of-bounds index). + +These optics can be combined in the following ways: + + * @(:.:) :: Optic is s a -> Optic js a b -> Optic (is :++: js) s b@ composes two optics, + allowing for focusing into nested structures. + \[ s \to a \to b \] + * @(:*:) :: (o1 :: Optic is s a) -> (o2 :: Optic js s b) -> Optic (Zip is js) s (Product o1 o2)@ + takes the product of two optics, to focus onto multiple components simultaneously. + \[ \begin{array}{ccc} + s & \to & a \\ + \downarrow & & \\ + b & & + \end{array} \] + * @OfType ty :: Optic '[] a ty@ focuses on all components of 'a' of type 'ty'. + This allows setting multiple components of the same type to a given value. + +Again, these are type-checked for validity. For instance, one cannot create a product setter +unless the two argument setters are disjoint. +(Note that this disallows product setters involving run-time indices, +as the required disjointness property can't be checked at compile-time.) + + +Getters\/setters are optics which support accessing\/setting components. +Type-level optics which can be reified to provide value-level getters and setters are defined +through the 'ReifiedGetter' and 'ReifiedSetter' type classes, instances of which are provided +for types used in this library in the "FIR.Syntax.Optics" module, or in this module +as far as combinators are concerned (e.g. the getter instance for the composite of two getters). + +The usage of these optics mimics the [Lens](http://hackage.haskell.org/package/lens/docs/Control-Lens.html) +library, but type-level arguments are provided with type applications. For instance: + +@ +> view @(Index 2) (V4 00 11 22 33) +22 +@ + +Note that numeric indexing starts at 0. + +@ +> view @AnIndex 2 (V4 00 11 22 33) +22 +@ + +Here the index is provided at the value-level instead of at the type-level. +Multiple indices can be provided in this manner: + + * as separate arguments for a composition, + * as pairs for a product optic. + +@ +> view @(Index 1 :.: Index 0) + $ M22 + 0 1 + 2 3 +1 +@ + +Here we first access the outer layer (the column with index 1, i.e. second of two columns), +then access the first component of that column. We always access the column first then the row, +following the column-major convention. +The type synonym 'Entry' can also be used: @Entry i j@ stands for @Index i :.: Index j@, +restricted to work specifically on matrices. + +Note that, in a composition, the outermost optic is on the left, and the nesting increases +as one reads from left to right. + +@ +> struct :: Struct '[ "a" ':-> V 4 Float, "b" ':-> V 2 Float ] +> struct = V4 0 1 2 3 :& V2 4 5 :& End + +> set @( (Name "a" :.: Index 2) :*: (Name "b" :.: Index 0) ) (V2 6 7) struct +{ "a" ':-> V4 0 1 6 3, "b" ':-> V2 7 5 } +@ + +Setting multiple values at once: focusing on the component at index 2 of the field @"a"@, +and the component at index 0 of the field @"b"@. + +Because the last type accessed by each optic in the product is a vector type, +the type-system combines these two setters using vectors. +This explains why the value-level argument to @set@ is a 2-vector. + +@ +> mat :: M 3 3 Double +> mat = M33 + 0 1 2 + 3 4 5 + 6 7 8 + +> set @( ( Entry 0 0 :*: Entry 0 2 :*: Entry 2 0 :*: Entry 2 2 ) :.: OfType Double ) 9 mat +M33 + 9 1 9 + 3 4 5 + 9 7 9 +@ + +'OfType' allows us to simultaneously set several entries (of the same type) to the same value. +__Warning:__ 'OfType' only creates a /setter/, not a /getter/. + +Note that the 'FIR.Syntax.Optics.Diag' synonym exists for focusing on the diagonal of a matrix: + +@ +> view @Diag mat +V3 0 4 8 +@ + +There is also the 'FIR.Syntax.Optics.Center' synonym for the center of a matrix, +which allows setting all diagonal entries of a square matrix to a single value: + +@ +> set @Center 9 mat +M33 + 9 1 2 + 3 9 5 + 6 7 9 +@ + +In fact 'FIR.Syntax.Optics.Center' can be simply defined as @Diag :.: OfType eltTy@. +-} + +module Control.Type.Optic + ( -- * Type-level optics + Optic(..), ShowOptic + -- $kind_coercion + , AnIndex, Index, Name + -- ** Getters and setters + , Gettable, Getter, ReifiedGetter(view) + , Settable, Setter, ReifiedSetter(set) + , ReifiedLens(over) + -- $kind_synonyms + , Whole, Part, Indices + -- ** Indexing information (used for overlap checking) + , IndexInfo(..), IndexChain + + -- ** Containers + -- $containers + , Container(..) + + -- * Getter & setter instances + -- $instances + + -- ** OfType optic + , OfType + -- $oftype_instances + + -- ** Composition of optics + , (:.:) + -- $composition_instances + + -- ** Product of optics + , (:*:), Prod, EndProd + , ProductComponents(..) + , ComponentsGettable, ComponentsSettable + , ArePairwiseDisjoint + -- $product_instances + + ) where + + +-- base +import Data.Kind + ( Type, Constraint ) +import Data.Proxy + ( Proxy(Proxy) ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import GHC.TypeLits + ( Symbol, AppendSymbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- fir +import Data.Product + ( HList(HNil, (:>)) + , IsProduct(fromHList, toHList) + , AreProducts + , MapHList + ) +import Data.Type.Error + ( IsRight, And ) +import Data.Type.List + ( type (:++:), Postpend + , Tail, MapTail + , Replicate, Length + , MapSingleton + , ZipCons + , SameLength(sSameLength) + , SSameLength(SSameSucc, SSameZero) + ) +import Data.Type.Maybe + ( IfNothingThen ) +import Data.Type.String + ( ShowNat ) +import Data.Function.Variadic + ( ListVariadic ) +import FIR.Prim.Image + ( Image ) +import {-# SOURCE #-} FIR.Prim.Types + ( PrimTy(FieldsOfType) ) + +---------------------------------------------------------------------- + +infixr 9 :.: +infixr 9 `ComposeO` +infixr 3 `ProductO` +infixr 3 :*: + +-- | Optic data (kind). +data Optic (is :: [Type]) (s :: k) (a :: Type) where + -- | Focus onto all the sub-parts which have a certain type. + OfType_ :: Type -> Optic is s a + -- | Optic with indexing information provided at run-time. + RTOptic_ :: Optic is s a + -- | Compile-time field (e.g. numeric index or symbolic field name). + Field_ :: fld -> Optic is s a + -- | Composition of optics. + ComposeO :: Optic is s a -> Optic js a b -> Optic ks s b + -- | Unbiased product of optics. + Prod_ :: ProductComponents iss s as -> Optic js s p + +-- | Wrapper to keep track of components of a product optic. +-- +-- The first argument keeps track of runtime indices. +-- Its length keeps track of how many additional arguments need to be provided when using the optic. +-- For instance, @ iss ~ [ [X1,X2], [Y1,Y2], [Z1,Z2] ]@ means that we expect 3 additional indexing arguments, +-- with first argument consisting of indices of types @X1@ and X2@, +-- second argument consisting of indices of types @Y1@ and @Y2@, +-- and third argument consisting of indices of types @Z1@ and @Z2@. +-- +-- @ view \@( optic :: Optic [ [x1,x2], [y1,y2], [z1,z2] ] S A) (x1,x2) (y1,y2) (z1,z2) s :: A @ +data ProductComponents (iss :: [[Type]]) (s :: k) (as :: [Type]) where + EndProd_ :: ProductComponents iss s as + ProductO :: Optic is s a -> ProductComponents iss s as -> ProductComponents jss s (a ': as) + +-- $kind_coercion +-- +-- /__Warning__/: the data constructors of the 'Optic' data type are not type-correct. +-- This is to bypass difficulties with kind coercions: +-- at the time of writing, GHC does not full support kind coercions, in that +-- given the context @a ~ b@, GHC is unable to unify a type +-- of kind @a@ with a type of kind @b@. +-- (See [GHC trac #15710](https://gitlab.haskell.org/ghc/ghc/issues/15710).) +-- +-- As a result, the constructors for the 'Optic' data type have overly general types. +-- Kind-correct type-level smart constructors are instead provided (and their use recommended): +-- +-- * 'AnIndex', 'Index', 'Name', 'OfType' create specific optics, +-- * ':.:' composes two optics (left-most argument = outer-most optic), +-- * 'Prod', ':*:' and 'EndProd' allow the formation of (unbiased) product optics. +-- +-- See also "FIR.Syntax.Images" for an overview of how to use optics with images. + + +-- | Run-time index (kind-correct). +type AnIndex (ix :: Type ) = RTOptic_ @'[ix] +-- | Compile-time index (kind-correct). +type Index (i :: Nat ) = Field_ @Nat @'[] i +-- | Compile-time field name (kind-correct). +type Name (k :: Symbol) = Field_ @Symbol @'[] k + + +-- | Optic for components of a particular type (kind-correct). +type OfType (ty :: Type) = (OfType_ ty :: Optic '[] s ty) +-- | Composition of optics (kind-correct). +type (:.:) (o1 :: Optic is s a) (o2 :: Optic js a b) + = ( (o1 `ComposeO` o2) :: Optic (is :++: js) s b ) +-- | Gather optics together in order to take an unbiased product over them (kind-correct). +type family (:*:) (o :: Optic is s a) (os :: ProductComponents iss s as) :: ProductComponents (ProductIndices is os) s (a ': as) where + ( o :: Optic is s a ) :*: EndProd_ + = o `ProductO` ( EndProd_ :: ProductComponents (Replicate (Length is) '[]) s '[] ) + ( o :: Optic is s a ) :*: ( os :: ProductComponents iss s as ) + = ( o `ProductO` os :: ProductComponents (ProductIndices is os) s (a ': as) ) +-- | Empty set of optic components. +type family EndProd :: ProductComponents '[] s '[] where + EndProd = EndProd_ +-- | Kind of indices resulting from a product. +type family ProductIndices (is :: [Type]) (os :: ProductComponents iss s as) :: [[Type]] where + ProductIndices is EndProd_ = MapSingleton is + ProductIndices is ( os :: ProductComponents iss s as ) = ZipCons is iss +-- | Unbiased product of a set of component optics (kind-correct). +type Prod (os :: ProductComponents iss s as) + = ( Prod_ os :: Optic (MapHList iss) s p ) +-- TODO: it would be nice to have "p" as a first argument for visible kind application +-- (this might require standalone kind signatures?) + +type family ShowOptic (o :: Optic is s a) :: ErrorMessage where + ShowOptic (OfType_ ty) = Text "OfType " :<>: ShowType ty + -- special case for image optics + ShowOptic + ( ( Field_ (k :: Symbol) :: Optic '[] i (Image props) ) + `ComposeO` + ( RTOptic_ :: Optic '[ _, _ ] (Image props) _ ) + ) + = Text "ImageTexel " :<>: ShowType k + ShowOptic (RTOptic_ :: Optic '[ix] s a) + = Text "AnIndex (" :<>: ShowType ix :<>: Text ")" + ShowOptic (RTOptic_ :: Optic is s a) + = Text "SomeIndices (" :<>: ShowType is :<>: Text ")" + ShowOptic (Field_ (i :: Nat)) + = Text "Index " :<>: ShowType i + ShowOptic (Field_ (k :: Symbol) :: Optic is (s :: Type) a) + = Text "Name " :<>: ShowType k + ShowOptic (Field_ (k :: Symbol) :: Optic is (s :: _) a) + = Text "Binding " :<>: ShowType k + ShowOptic (o1 `ComposeO` o2) + = Text "( " :<>: ShowOptic o1 :<>: Text " :.: " :<>: ShowOptic o2 :<>: Text " )" + ShowOptic (Prod_ comps) + = Text "Prod ( " :<>: ShowComponents comps :<>: Text " )" + +type family ShowComponents (comps :: ProductComponents iss s as) :: ErrorMessage where + ShowComponents EndProd_ = Text "EndProd" + ShowComponents (o `ProductO` comps) + = ShowOptic o :<>: Text " :*: " :<>: ShowComponents comps + +---------------------------------------------------------------------- +-- Type classes and synonyms. + +-- | Type-level getter. +class Gettable (optic :: Optic is (s :: k) a) | optic -> is k s a where + +type Getter (optic :: Optic is (s :: Type) a) = ListVariadic (is `Postpend` s) a + +-- | Type-level getter which can be turned into a value-level getter. +class Gettable optic => ReifiedGetter optic where + view :: Getter optic + +-- | Type-level setter. +class Settable (optic :: Optic is (s :: k) a) | optic -> is k s a where + +type Setter (optic :: Optic is (s :: Type) a) = ListVariadic (is `Postpend` a `Postpend` s) s + +-- | Type-level setter which can be turned into a value-level setter. +class Settable optic => ReifiedSetter optic where + set :: Setter optic + +type Over (optic :: Optic is (s :: Type) a) = ListVariadic (is `Postpend` (a -> a) `Postpend` s) s + +-- | Type-level lens: can be used to modify the part under its focus. +class ( ReifiedSetter optic, ReifiedGetter optic ) => ReifiedLens optic where + over :: Over optic + +-- $kind_synonyms +-- +-- Synonyms that allow kind variables to remain invisible. +-- +-- See [explicit specificity (GHC proposal #26)](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0026-explicit-specificity.rst). + +type Whole (optic :: Optic is s a) = s +type Part (optic :: Optic is s a) = a +type Indices (optic :: Optic is s a) = is + +------------------------------- +-- $containers +-- +-- Auxiliary internal type class describing types that provide the functionality necessary +-- to be able to create product optics. +-- +-- This type class contains type-level methods for checking disjointness of optics, +-- in particular the ability to check that a numeric index +-- and a symbolic field name do not refer to the same component, +-- when applicable. + +class Container (s :: Type) where + + -- | Compute a numeric indexing from a symbolic index. + -- Can return a type-error if symbolic indexing is not supported. + -- + -- Chiefly needed for overlap checking for 'FIR.Prim.Struct.Struct's. + type FieldIndexFromName s (k :: Symbol) :: Nat + -- | Default instance: don't allow symbolic indexing. Can be overriden. + type FieldIndexFromName s k + = TypeError + ( Text "Attempt to index object of type " :<>: ShowType s + :<>: Text " with symbolic index " :<>: ShowType k :<>: Text "." + :$$: Text "This type does not support symbolic indexing." + ) + +---------------------------------------------------------------------- +-- $instances +-- +-- This module defines getter and setter instances that are applicable in general situations: +-- +-- * composition of optics, +-- * product of optics, +-- +-- In other words, this module provides the general framework for /combining/ optics. +-- To manipulate specific types (e.g. the ability to access a component of a vector by its index), +-- corresponding specific instances are required. +-- +-- The specific instances, as they pertain to datatypes used by this library, +-- are found in the "FIR.Syntax.Optics" module. +-- This includes instances for vectors, matrices and structs. +-- See also "FIR.Syntax.Images" for the peculiar 'FIR.Syntax.Images.ImageTexel' lens. + +-------------------------- +-- $lens_instances +-- +-- Combine a getter and a setter into a lens. + +class GetterAndSetter is s a where + getAndSet + :: ListVariadic (is `Postpend` s) a + -> ListVariadic (is `Postpend` a `Postpend` s) s + -> ListVariadic (is `Postpend` (a -> a) `Postpend` s) s + +instance ( s ~ ListVariadic '[] s, a ~ ListVariadic '[] a ) => GetterAndSetter '[] s a where + getAndSet view1 set1 f s = set1 ( f (view1 s) ) s + +instance GetterAndSetter is s a => GetterAndSetter (i ': is) s a where + getAndSet view1 set1 i + = getAndSet @is @s @a (view1 i) (set1 i) + +instance forall is s a (optic :: Optic is s a). + ( ReifiedGetter optic, ReifiedSetter optic + , GetterAndSetter is s a + ) + => ReifiedLens optic where + over = getAndSet @is @s @a (view @optic) (set @optic) + +-------------------------- +-- $oftype_instances +-- +-- The 'OfType' optic constructor creates setters, not getters. +-- So we prevent setter instances. +-- +-- Getter instances are defined individually for specific types, +-- see "FIR.Syntax.Optics". + +instance + ( TypeError ( Text "get: cannot use 'OfType' optic as a getter." ) ) + => Gettable (OfType_ ty :: Optic i s a) where +instance + ( TypeError ( Text "get: cannot use 'OfType' optic as a getter." ) ) + => ReifiedGetter (OfType_ ty :: Optic i s a) where + view = error "unreachable" + +-- Default instance to use: "a" does not contain components of type "ty". +-- Should be overridden by specific instances that +-- provide evidence that "a" does in fact contain components of type "ty". +instance {-# OVERLAPPABLE #-} + ( r ~ ty, empty ~ '[] ) + => Settable (OfType_ ty :: Optic empty a r) where +instance {-# OVERLAPPABLE #-} + ( r ~ ty, empty ~ '[], ListVariadic '[] a ~ a ) + => ReifiedSetter (OfType_ ty :: Optic empty a r) where + set _ = id + +-------------------------- +-- $composition_instances +-- +-- Included are the following instances for composed optics: +-- +-- * the composite of two getters is a getter, +-- * the composite of a lens (outside) with a setter (inside) is a setter. +-- +-- Note that compositions where the first optic accesses from a monadic state +-- is not included here. +-- This is to provide improved type inference, see "FIR.Syntax.Optics". + +instance forall (s :: Type) is js ks a b (o1 :: Optic is s a) (o2 :: Optic js a b). + ( Gettable o1 + , Gettable o2 + , ks ~ (is :++: js) + ) => Gettable ((o1 `ComposeO` o2) :: Optic ks s b) where +instance forall (s :: Type) is js ks a b (o1 :: Optic is s a) (o2 :: Optic js a b). + ( Settable o1 + , Settable o2 + , ks ~ (is :++: js) + ) => Settable ((o1 `ComposeO` o2) :: Optic ks s b) where + +instance forall (s :: Type) is js ks a b (o1 :: Optic is s a) (o2 :: Optic js a b). + ( ReifiedGetter o1 + , ReifiedGetter o2 + , ComposeGetters is js s a b + , ks ~ (is :++: js) + ) + => ReifiedGetter ((o1 `ComposeO` o2) :: Optic ks s b) where + view = composeGetters @is @js @s @a @b (view @o1) (view @o2) + +class ComposeGetters is js s a b where + composeGetters :: ListVariadic (is `Postpend` s) a + -> ListVariadic (js `Postpend` a) b + -> ListVariadic ((is :++: js) `Postpend` s) b +instance (a ~ ListVariadic '[] a) => ComposeGetters '[] '[] s a b where + composeGetters view1 view2 = view2 . view1 +instance ComposeGetters is js s a b => ComposeGetters (i ': is) js s a b where + composeGetters view1 view2 i + = composeGetters @is @js @s @a @b (view1 i) view2 +instance ComposeGetters '[] js s a b => ComposeGetters '[] (j ': js) s a b where + composeGetters view1 view2 j + = composeGetters @'[] @js @s @a @b view1 (view2 j) + +instance forall (s :: Type) is js ks a b (o1 :: Optic is s a) (o2 :: Optic js a b). + ( ReifiedSetter o1 + , ReifiedSetter o2 + , ReifiedGetter o1 + , ComposeSetters is js s a b + , ks ~ (is :++: js) + ) + => ReifiedSetter ((o1 `ComposeO` o2) :: Optic ks s b) where + set = composeSetters @is @js @s @a @b (view @o1) (set @o1) (set @o2) + +class ComposeSetters is js s a b where + composeSetters :: ListVariadic (is `Postpend` s) a + -> ListVariadic (is `Postpend` a `Postpend` s) s + -> ListVariadic (js `Postpend` b `Postpend` a) a + -> ListVariadic ((is :++: js) `Postpend` b `Postpend` s) s +instance (a ~ ListVariadic '[] a) => ComposeSetters '[] '[] s a b where + composeSetters view1 set1 set2 b s + = set1 (set2 b (view1 s)) s +instance ComposeSetters is js s a b => ComposeSetters (i ': is) js s a b where + composeSetters view1 set1 set2 i + = composeSetters @is @js @s @a @b (view1 i) (set1 i) set2 +instance ComposeSetters '[] js s a b => ComposeSetters '[] (j ': js) s a b where + composeSetters view1 set1 set2 j + = composeSetters @'[] @js @s @a @b view1 set1 (set2 j) + +-------------------------- +-- $product_instances +-- +-- Included are the following instances for product optics: +-- +-- * the product of disjoint setters is a setter, +-- * the product of getters is a getter. + +------------- +-- disjointness checking + +data IndexInfo + = ThisIndex Nat + | AnyIndex -- any index (e.g. runtime index, or a situation such as "TypeOf a :: Optic '[] (Array n a) a") + +type IndexChain = [IndexInfo] + +data IndexChoice + = OneIndex IndexInfo + | Choice [IndexChoices] + +type IndexChoices = [IndexChoice] + +type family Disjoint ( o1 :: Optic is s a ) ( o2 :: Optic js s b ) :: Either ErrorMessage () where + Disjoint o1 o2 + = ErrorIfOverlap o1 o2 + ( FirstOverlap (IndexChoicesOf o1) (IndexChoicesOf o2) ) + +type ArePairwiseDisjoint (os :: ProductComponents iss s as) + = ( IsRight (PairwiseDisjoint os) :: Constraint ) + +type family PairwiseDisjoint (os :: ProductComponents iss s as) :: Either ErrorMessage () where + PairwiseDisjoint EndProd_ = Right '() + PairwiseDisjoint (o `ProductO` os) = + ( o `DisjointFrom` os ) `And` PairwiseDisjoint os + +type family DisjointFrom (o :: Optic is s a) (os :: ProductComponents iss s as) :: Either ErrorMessage () where + DisjointFrom o EndProd_ = Right '() + DisjointFrom o (o' `ProductO` os) = + Disjoint o o' `And` (o `DisjointFrom` os) + +type family ErrorIfOverlap + ( o1 :: Optic is s a ) + ( o2 :: Optic js s b ) + ( overlap :: Maybe [Nat] ) + :: Either ErrorMessage () + where + ErrorIfOverlap _ _ 'Nothing = Right '() + ErrorIfOverlap (o1 :: Optic is s a) o2 ('Just nfo) + = TypeError + ( Text "Cannot create product setter at type:" + :$$: Text " " :<>: ShowType s + :$$: Text "Overlap between optics" + :$$: Text " - " :<>: ShowOptic o1 :<>: Text "," + :$$: Text " - " :<>: ShowOptic o2 + :<>: IndexChainErrorMessage nfo + ) + +type family IndexChainErrorMessage (chain :: [Nat]) :: ErrorMessage where + IndexChainErrorMessage '[] + = Text "." + IndexChainErrorMessage '[i] + = Text "," :$$: Text "at index " :<>: Text (ShowNat i) :<>: Text "." + IndexChainErrorMessage is + = Text "," :$$: Text "at index chain ( " :<>: Text (ShowIndexChain is) :<>: Text " )." + +type family ShowIndexChain (chain :: [Nat]) :: Symbol where + ShowIndexChain '[ ] = "" + ShowIndexChain '[i] = ShowNat i + ShowIndexChain (i ': j ': is) + = ShowNat i `AppendSymbol` " -- " `AppendSymbol` ( ShowIndexChain (j ': is) ) + +type family FirstOverlap + ( nfo1 :: IndexChoices ) + ( nfo2 :: IndexChoices ) + :: Maybe [Nat] + where + FirstOverlap '[] _ = Just '[] + FirstOverlap _ '[] = Just '[] + FirstOverlap ( OneIndex i1 ': nfo1 ) ( OneIndex i2 ': nfo2 ) + = FirstOverlapOneIndex i1 nfo1 i2 nfo2 + FirstOverlap ( Choice nfos1 ': nfo1 ) ( Choice nfos2 ': nfo2 ) + = FirstCrosswiseOverlap nfos1 (Just nfo1) nfos2 (Just nfo2) + FirstOverlap ( Choice nfos1 ': nfo1 ) nfo2 + = FirstCrosswiseOverlap nfos1 (Just nfo1) '[nfo2] Nothing + FirstOverlap nfo1 ( Choice nfos2 ': nfo2 ) + = FirstCrosswiseOverlap '[nfo1] Nothing nfos2 (Just nfo2) + +type family FirstOverlapOneIndex + ( i1 :: IndexInfo ) + ( nfo1 :: IndexChoices ) + ( i2 :: IndexInfo ) + ( nfo2 :: IndexChoices ) + :: Maybe [Nat] where + FirstOverlapOneIndex (ThisIndex i ) nfo1 (ThisIndex i ) nfo2 + = FmapConsMaybe i ( FirstOverlap nfo1 nfo2 ) + FirstOverlapOneIndex (ThisIndex i1) _ (ThisIndex i2) _ + = Nothing + FirstOverlapOneIndex (ThisIndex i1) nfo1 AnyIndex nfo2 + = FmapConsMaybe i1 ( FirstOverlap nfo1 nfo2 ) + FirstOverlapOneIndex AnyIndex nfo1 (ThisIndex i2) nfo2 + = FmapConsMaybe i2 ( FirstOverlap nfo1 nfo2 ) + FirstOverlapOneIndex AnyIndex nfo1 AnyIndex nfo2 + = FmapConsMaybe 0 ( FirstOverlap nfo1 nfo2 ) + +type family FirstCrosswiseOverlap + ( nfos1 :: [IndexChoices] ) + ( nxt1 :: Maybe IndexChoices ) + ( nfos2 :: [IndexChoices] ) + ( nxt2 :: Maybe IndexChoices ) + :: Maybe [Nat] + where + FirstCrosswiseOverlap '[] _ _ _ + = Nothing + FirstCrosswiseOverlap ( nfo1 ': nfos1 ) mbNxt1 nfos2 mbNxt2 + = ( FirstOverlapIn nfo1 mbNxt1 nfos2 mbNxt2 ) + `IfNothingThen` + ( FirstCrosswiseOverlap nfos1 mbNxt1 nfos2 mbNxt2 ) + +type family FirstOverlapIn + ( nfo1 :: IndexChoices ) + ( nxt1 :: Maybe IndexChoices ) + ( nfos2 :: [IndexChoices] ) + ( nxt2 :: Maybe IndexChoices ) + :: Maybe [Nat] + where + FirstOverlapIn _ _ '[] _ + = Nothing + FirstOverlapIn nfo1 mbNxt1 ( nfo2 ': nfos2 ) mbNxt2 + = ( FirstOverlap ( nfo1 `MaybeAppend` mbNxt1 ) ( nfo2 `MaybeAppend` mbNxt2 ) ) + `IfNothingThen` + ( FirstOverlapIn nfo1 mbNxt1 nfos2 mbNxt2 ) + +type family FmapConsMaybe ( i :: k ) ( js :: Maybe [k] ) :: Maybe [k] where + FmapConsMaybe _ Nothing = Nothing + FmapConsMaybe i (Just js) = Just (i ': js) + +type family MaybeAppend ( xs :: [k] ) ( mb_ys :: Maybe [k] ) :: [k] where + MaybeAppend xs Nothing = xs + MaybeAppend xs (Just ys) = xs :++: ys + +type family IndexChoicesOf ( o :: Optic is s a ) :: IndexChoices where + IndexChoicesOf ( Field_ ( i :: Nat ) ) = '[ OneIndex (ThisIndex i) ] + IndexChoicesOf ( Field_ ( k :: Symbol ) :: Optic is s a ) + = '[ OneIndex (ThisIndex ( FieldIndexFromName s k )) ] + IndexChoicesOf ( Field_ ( i :: fld ) ) + = TypeError + ( Text "Cannot create product setter." + :$$: Text "Index " :<>: ShowType i + :<>: Text " has unsupported kind " :<>: ShowType fld :<>: Text "." + ) + IndexChoicesOf RTOptic_ = '[ OneIndex AnyIndex ] + IndexChoicesOf ( o1 `ComposeO` o2 ) + = IndexChoicesOf o1 :++: IndexChoicesOf o2 + IndexChoicesOf ( Prod_ comps ) + = '[ Choice ( ComponentIndexChoices comps ) ] + IndexChoicesOf ( OfType_ ty :: Optic is s a ) + = '[ Choice ( MapMapOneIndex (FieldsOfType s ty) ) ] + + +type family ComponentIndexChoices ( comps :: ProductComponents iss s as ) :: [IndexChoices] where + ComponentIndexChoices EndProd_ = '[] + ComponentIndexChoices (o `ProductO` os) + = IndexChoicesOf o ': ComponentIndexChoices os + +type family MapMapOneIndex ( flds :: [IndexChain] ) :: [IndexChoices] where + MapMapOneIndex '[] = '[] + MapMapOneIndex ( nfo ': nfos ) = MapOneIndex nfo ': MapMapOneIndex nfos + +type family MapOneIndex ( flds :: IndexChain ) :: IndexChoices where + MapOneIndex '[] = '[] + MapOneIndex ( nfo ': nfos ) = OneIndex nfo ': MapOneIndex nfos + +------------- +-- instances + +class ComponentsGettable (os :: ProductComponents iss s as) where +instance ComponentsGettable EndProd_ where +instance ( ComponentsGettable os, Gettable o ) => ComponentsGettable (o `ProductO` os) +class ComponentsSettable (os :: ProductComponents iss s as) where +instance ComponentsSettable EndProd_ where +instance ( ComponentsSettable os, Settable o ) => ComponentsSettable (o `ProductO` os) + +instance forall + ( iss :: [[Type]] ) + ( js :: [Type] ) + ( k :: Type ) + ( s :: k ) + ( as :: [Type] ) + ( p :: Type ) + ( os :: ProductComponents iss s as ) + . + ( ComponentsGettable os + , IsProduct p as + , AreProducts js iss as + ) + => Gettable (Prod_ os :: Optic js s p) + where + +instance forall + ( iss :: [[Type]] ) + ( js :: [Type] ) + ( k :: Type ) + ( s :: k ) + ( as :: [Type] ) + ( p :: Type ) + ( os :: ProductComponents iss s as ) + . + ( ComponentsSettable os + , IsProduct p as + , AreProducts js iss as + , ArePairwiseDisjoint os + ) + => Settable (Prod_ os :: Optic js s p) + where + +instance forall + ( iss :: [[Type]] ) + ( js :: [Type] ) + ( s :: Type ) + ( as :: [Type] ) + ( p :: Type ) + ( os :: ProductComponents iss s as ) + . + ( ComponentsGettable os + , IsProduct p as + , AreProducts js iss as + , MultiplyGetters iss js s as p + , GetViewers os + ) + => ReifiedGetter (Prod_ os :: Optic js s p) + where + view = multiplyGetters @iss @js @s @as @p + ( viewers @iss @s @as @os ) + +instance forall + ( iss :: [[Type]] ) + ( js :: [Type] ) + ( s :: Type ) + ( as :: [Type] ) + ( p :: Type ) + ( os :: ProductComponents iss s as ) + . + ( ComponentsSettable os + , IsProduct p as + , AreProducts js iss as + , ArePairwiseDisjoint os + , MultiplySetters iss js s as p + , GetSetters os + ) + => ReifiedSetter (Prod_ os :: Optic js s p) + where + set = multiplySetters @iss @js @s @as @p + ( setters @iss @s @as @os ) + +class GetViewers (os :: ProductComponents iss (s :: Type) as) where + viewers :: Viewers iss s as + +instance ( as ~ '[] ) => GetViewers ( EndProd_ :: ProductComponents iss s as ) where + viewers = NilViewer +instance forall + ( iss :: [[Type]] ) + ( kss :: [[Type]] ) + ( is :: [Type] ) + ( s :: Type ) + ( as :: [Type] ) + ( a :: Type ) + ( o :: Optic is s a ) + ( os :: ProductComponents iss s as ) + . + ( GetViewers os + , ReifiedGetter o + , SameLength is kss + , kss ~ ZipCons is iss + ) + => GetViewers (o `ProductO` os :: ProductComponents kss s (a ': as)) where + viewers = ConsViewer @is @s @a (sSameLength @_ @_ @is @kss) Proxy Proxy Proxy + (view @o) (viewers @iss @s @as @os) + +class GetSetters (os :: ProductComponents iss (s :: Type) as) where + setters :: Setters iss s as + +instance ( as ~ '[] ) => GetSetters ( EndProd_ :: ProductComponents iss s as ) where + setters = NilSetter +instance forall + ( iss :: [[Type]] ) + ( kss :: [[Type]] ) + ( is :: [Type] ) + ( s :: Type ) + ( as :: [Type] ) + ( a :: Type ) + ( o :: Optic is s a ) + ( os :: ProductComponents iss s as ) + . + ( GetSetters os + , ReifiedSetter o + , SameLength is kss + , kss ~ ZipCons is iss + ) + => GetSetters (o `ProductO` os :: ProductComponents kss s (a ': as)) where + setters = ConsSetter @is @s @a (sSameLength @_ @_ @is @kss) Proxy Proxy Proxy + (set @o) (setters @iss @s @as @os) + +class MultiplyGetters (iss :: [[Type]]) (js :: [Type]) (s :: Type) (as :: [Type]) (p :: Type) where + multiplyGetters :: Viewers iss s as -> ListVariadic (js `Postpend` s) p + +class MultiplySetters (iss :: [[Type]]) (js :: [Type]) (s :: Type) (as :: [Type]) (p :: Type) where + multiplySetters :: Setters iss s as -> ListVariadic (js `Postpend` p `Postpend` s) s + +instance ( IsProduct p as, p ~ ListVariadic '[] p ) + => MultiplyGetters iss '[] s as p where + multiplyGetters :: Viewers iss s as -> s -> p + multiplyGetters views s = fromHList @p @as ( applyGetters views s ) + +instance ( IsProduct j is, SameLength is as, MultiplyGetters iss js s as p ) + => MultiplyGetters (is ': iss) (j ': js) s as p where + multiplyGetters :: Viewers (is ': iss) s as -> ( j -> ListVariadic (js `Postpend` s) p ) + multiplyGetters views j = + multiplyGetters @iss @js @s @as @p + ( passGetterIndex (sSameLength @_ @_ @is @as) ( toHList j ) views ) + +instance ( IsProduct p as, s ~ ListVariadic '[] s ) + => MultiplySetters iss '[] s as p where + multiplySetters :: Setters iss s as -> p -> s -> s + multiplySetters sets p s = applySetters sets ( toHList @p @as p ) s + +instance ( IsProduct j is, SameLength is as, MultiplySetters iss js s as p ) + => MultiplySetters (is ': iss) (j ': js) s as p where + multiplySetters :: Setters (is ': iss) s as -> ( j -> ListVariadic (js `Postpend` p `Postpend` s) s ) + multiplySetters sets j + = multiplySetters @iss @js @s @as @p + ( passSetterIndex (sSameLength @_ @_ @is @as) ( toHList j ) sets ) + + +applyGetters :: Viewers iss s bs -> s -> HList bs +applyGetters NilViewer _ = HNil +applyGetters ( ConsViewer _ _ _ (_ :: Proxy b) getter getters ) s = + case getters of + ( _ :: Viewers jss s cs ) + -> ( unsafeCoerce getter :: s -> b ) s + :> applyGetters ( unsafeCoerce getters :: Viewers '[] s cs ) s + +applySetters :: Setters iss s bs -> HList bs -> s -> s +applySetters NilSetter _ s = s +applySetters ( ConsSetter _ _ _ (_ :: Proxy b) setter sets ) (b :> bs) s = + case sets of + ( _ :: Setters jss s cs ) + -> applySetters ( unsafeCoerce sets :: Setters '[] s cs ) bs + $ ( unsafeCoerce setter :: b -> s -> s ) b s + +passGetterIndex + :: forall (js :: [Type]) (jss :: [[Type]]) (s :: Type) (as :: [Type]) + . SSameLength js as -> HList js -> Viewers (js ': jss) s as -> Viewers jss s as +passGetterIndex SSameZero _ _ = unsafeCoerce NilViewer +passGetterIndex (SSameSucc ( same1 :: SSameLength t_js t_as ) ) js views = + case ( js, views ) of + ( (k :: j) :> (ks :: HList t_js), ConsViewer same2 (_ :: Proxy is) (_ :: Proxy iss) _ getter getters ) -> + case same2 of + ( sameSucc@(SSameSucc (same3 :: SSameLength t_is jss) ) ) -> + case sameSucc of + ( _ :: SSameLength (i ': t_is) (js ': jss) ) + | Refl <- ( unsafeCoerce Refl :: ZipCons t_is (Tail iss) :~: jss ) + , Refl <- ( unsafeCoerce Refl :: ( t_js ': MapTail jss ) :~: iss ) + , Refl <- ( unsafeCoerce Refl :: i :~: j ) + , Proxy :: Proxy bss <- Proxy @(Tail iss) + -> ConsViewer same3 (Proxy @t_is) (Proxy @bss) Proxy + ( getter k ) + ( passGetterIndex @t_js @(MapTail jss) @s @t_as same1 ks getters ) + +passSetterIndex + :: forall (js :: [Type]) (jss :: [[Type]]) (s :: Type) (as :: [Type]) + . SSameLength js as -> HList js -> Setters (js ': jss) s as -> Setters jss s as +passSetterIndex SSameZero _ _ = unsafeCoerce NilViewer +passSetterIndex (SSameSucc ( same1 :: SSameLength t_js t_as ) ) js sets = + case ( js, sets ) of + ( (k :: j) :> (ks :: HList t_js), ConsSetter same2 (_ :: Proxy is) (_ :: Proxy iss) _ setter setts ) -> + case same2 of + ( sameSucc@(SSameSucc (same3 :: SSameLength t_is jss) ) ) -> + case sameSucc of + ( _ :: SSameLength (i ': t_is) (js ': jss) ) + | Refl <- ( unsafeCoerce Refl :: ZipCons t_is (Tail iss) :~: jss ) + , Refl <- ( unsafeCoerce Refl :: ( t_js ': MapTail jss ) :~: iss ) + , Refl <- ( unsafeCoerce Refl :: i :~: j ) + , Proxy :: Proxy bss <- Proxy @(Tail iss) + -> ConsSetter same3 (Proxy @t_is) (Proxy @(Tail iss)) Proxy + ( setter k ) + ( passSetterIndex @t_js @bss @s @t_as same1 ks setts ) + +data Viewers (iss :: [[Type]]) (s :: Type) (as :: [Type]) where + NilViewer :: Viewers iss s '[] -- iss should always be a list of empty lists + ConsViewer :: forall (is :: [Type]) (s :: Type) (a :: Type) (iss :: [[Type]]) (as :: [Type]) + . SSameLength is (ZipCons is iss) + -> Proxy is + -> Proxy iss + -> Proxy a + -> ListVariadic (is `Postpend` s) a + -> Viewers iss s as + -> Viewers (ZipCons is iss) s (a ': as) + +data Setters (iss :: [[Type]]) (s :: Type) (as :: [Type]) where + NilSetter :: Setters iss s '[] -- iss should always be a list of empty lists + ConsSetter :: forall (is :: [Type]) (s :: Type) (a :: Type) (iss :: [[Type]]) (as :: [Type]) + . SSameLength is (ZipCons is iss) + -> Proxy is + -> Proxy iss + -> Proxy a + -> ListVariadic (is `Postpend` a `Postpend` s) s + -> Setters iss s as + -> Setters (ZipCons is iss) s (a ': as) diff --git a/src/Control/Type/Optic.hs-boot b/src/Control/Type/Optic.hs-boot new file mode 100644 --- /dev/null +++ b/src/Control/Type/Optic.hs-boot @@ -0,0 +1,51 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeOperators #-} + +module Control.Type.Optic + ( Optic + , Whole, Part, Indices + , IndexInfo(..), IndexChain + , Gettable, ReifiedGetter + , Settable, ReifiedSetter + ) where + +-- base +import Data.Kind + ( Type ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Function.Variadic + ( ListVariadic ) +import Data.Type.List + ( Postpend ) + +------------------------------------------------------------ + +data Optic (is :: [Type]) (s :: k) (a :: Type) +type role Optic phantom phantom phantom + +type Whole (optic :: Optic is s a) = s +type Part (optic :: Optic is s a) = a +type Indices (optic :: Optic is s a) = is + +data IndexInfo + = ThisIndex Nat + | AnyIndex + +type IndexChain = [IndexInfo] + +class Gettable (optic :: Optic (is :: [Type]) (s :: k) a) | optic -> is k s a +type Getter (optic :: Optic is (s :: Type) a) = ListVariadic (is `Postpend` s) a +class Gettable optic => ReifiedGetter optic where + view :: Getter optic + +class Settable (optic :: Optic is (s :: k) a) | optic -> is k s a +type Setter (optic :: Optic is (s :: Type) a) = ListVariadic (is `Postpend` a `Postpend` s) s +class Settable optic => ReifiedSetter optic where + set :: Setter optic diff --git a/src/Data/Binary/Class/Put.hs b/src/Data/Binary/Class/Put.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Class/Put.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE TypeApplications #-} + +{-| +Module: Data.Binary.Class.Put + +One half of the 'Data.Binary.Binary' type class: putting. + +This type class is used to provide arguments to @SPIR-V@ +instructions; everything comes in multiples of 'Word32'. + +The instances provided in this module are /little endian/, +in agreement with the default endianness for @SPIR-V@ assembly. + +Note: this type class is __not__ concerned with memory layout on the GPU. +GPU memory layout is managed using @SPIR-V@ decorations, in conjunction with @Vulkan@. +This type class is instead used internally, to emit binary SPIR-V assembly. + +-} + +module Data.Binary.Class.Put + ( + -- * Put type class + Put(..) + -- ** Instances + -- $instances + , PutWord32Enum(..) + ) where + +-- base +import Data.Coerce + ( coerce ) +import Data.Int + ( Int8,Int16,Int32,Int64 ) +import Data.Semigroup + ( stimes ) +import Data.Word + ( Word8,Word16,Word32,Word64 ) +import Foreign.C.Types + ( CUShort(CUShort) ) + +-- binary +import qualified Data.Binary.Put as Binary + ( PutM + , putWord8, putWord16le + , putWord32le, putWord64le + , putInt32le, putInt64le + , putFloatle, putDoublele + , putShortByteString + ) + +-- bytestring +import qualified Data.ByteString.Short as ShortByteString + ( length ) + +-- half +import Numeric.Half + ( Half(Half) ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( toShortByteString ) + +---------------------------------------------------------------------------- +-- Put type class + +-- | One half of 'Data.Binary.Binary'. +class Put a where + put :: a -> Binary.PutM () + -- | Memory footprint, as a multiple of __32 bits__ + -- (/not/ the usual 8 bits as in 'Foreign.Storable.sizeOf'). + wordCount :: a -> Word32 + +--------------------------------------------------------------------------- +-- $instances +-- +-- Little-endian instances are provided for 'Put', +-- as these are best suited to @SPIR-V@. +-- +-- Note that types smaller than 32 bits are immediately padded: +-- this type class is purely used for specifying arguments +-- to @SPIR-V@ instructions, and the smallest allowed size is 32 bits; +-- it is not possible to tightly pack arguments of smaller sizes. + +instance Put Word8 where + put = Binary.putWord32le . fromIntegral + wordCount _ = 1 + +instance Put Word16 where + put = Binary.putWord32le . fromIntegral + wordCount _ = 1 + +instance Put Word32 where + put = Binary.putWord32le + wordCount _ = 1 + +instance Put Word64 where + put = Binary.putWord64le + wordCount _ = 2 + +instance Put Int8 where + put = Binary.putInt32le . fromIntegral + wordCount _ = 1 + +instance Put Int16 where + put = Binary.putInt32le . fromIntegral + wordCount _ = 1 + +instance Put Int32 where + put = Binary.putInt32le + wordCount _ = 1 + +instance Put Int64 where + put = Binary.putInt64le + wordCount _ = 2 + +instance Put Half where + put h = do + Binary.putWord16le (coerce h) + Binary.putWord16le 0 + wordCount _ = 1 + +instance Put Float where + put = Binary.putFloatle + wordCount _ = 1 + +instance Put Double where + put = Binary.putDoublele + wordCount _ = 2 + +-- | @C@-style string +instance Put ShortText where + put lit = + let n = ShortByteString.length (ShortText.toShortByteString lit) + pad = 4 - (n `mod` 4) + in Binary.putShortByteString (ShortText.toShortByteString lit) + <> (pad `stimes` Binary.putWord8 0) + wordCount lit + = let n = fromIntegral $ ShortByteString.length (ShortText.toShortByteString lit) + in 1 + (n `div` 4) + +---------------------------------------------------------------------------- +-- | Newtype for 'Put' instance using 'Enum'. +-- +-- Useful with deriving via: +-- @ data ... deriving Put via (PutWord32Enum ...) @. +newtype PutWord32Enum a = PutWord32Enum { runPutWord32Enum :: a } + +instance Enum a => Put (PutWord32Enum a) where + put = put @Word32 . fromIntegral . fromEnum . runPutWord32Enum + wordCount _ = 1 diff --git a/src/Data/Constraint/All.hs b/src/Data/Constraint/All.hs new file mode 100644 --- /dev/null +++ b/src/Data/Constraint/All.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: Data.Constraint.All + +This module provides the ability to take a conjunction of a list of constraints. + +Includes a reflection mechanism to enable resolution of individual constraints. +-} + +module Data.Constraint.All + ( AllDict(NilDict, ConsDict) + , All(allDict) + ) + where + +import Data.Kind + ( Constraint ) + +------------------------------------------------------------ + +data AllDict (c :: k -> Constraint) (as :: [k]) where + NilDict :: AllDict c '[] + ConsDict :: (c a, All c as) => AllDict c (a ': as) + +class All c as where + allDict :: AllDict c as + +instance All c '[] where + allDict = NilDict + +instance ( c a, All c as ) => All c (a ': as) where + allDict = ConsDict diff --git a/src/Data/Containers/Traversals.hs b/src/Data/Containers/Traversals.hs new file mode 100644 --- /dev/null +++ b/src/Data/Containers/Traversals.hs @@ -0,0 +1,25 @@ +{-| +Module: Data.Containers.Traversals + +Defines some folds/traversals on 'Data.Map.Map' and 'Data.Set.Set' that are not provided by the containers library. +-} + +module Data.Containers.Traversals where + +-- containers +import Data.Map + ( Map ) +import qualified Data.Map.Strict as Map + ( foldrWithKey ) +import Data.Set + ( Set ) +import qualified Data.Set as Set + ( foldr' ) + +---------------------------------------------------------------------------- + +traverseWithKey_ :: Applicative t => (k -> v -> t u) -> Map k v -> t () +traverseWithKey_ f = Map.foldrWithKey (\k a b -> f k a *> b) (pure ()) + +traverseSet_ :: Applicative t => (a -> t u) -> Set a -> t () +traverseSet_ f = Set.foldr' ( \a b -> f a *> b ) (pure ()) diff --git a/src/Data/Finite/With.hs b/src/Data/Finite/With.hs new file mode 100644 --- /dev/null +++ b/src/Data/Finite/With.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: Data.Finite.With + +Allows a function expecting a type-level natural to be passed a 'Data.Finite.Finite'. +-} + + +module Data.Finite.With + ( withFinite ) + where + +-- base +import Data.Proxy + ( Proxy ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import GHC.TypeNats + ( Nat, KnownNat + , SomeNat(..), someNatVal + , CmpNat + ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- finite-typelits +import Data.Finite + ( Finite, getFinite ) + +---------------------------------------------------------------------- + +-- | Pass a 'Finite' to a function expecting a type-level natural (passed via a 'Proxy'). +withFinite + :: forall (n :: Nat) r + . ( forall i. ( KnownNat i, CmpNat i n ~ 'LT ) => Proxy i -> r ) + -> Finite n + -> r +withFinite f j = case someNatVal ( fromIntegral $ getFinite j ) of + ( SomeNat ( px :: Proxy j ) ) -> + case unsafeCoerce Refl :: CmpNat j n :~: 'LT of + Refl -> f px diff --git a/src/Data/Function/Variadic.hs b/src/Data/Function/Variadic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Function/Variadic.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Data.Function.Variadic + +Type families for variadic functions. +-} + +module Data.Function.Variadic where + +-- base +import Data.Int + ( Int8,Int16,Int32,Int64 ) +import Data.Kind + ( Type ) +import Data.Word + ( Word8,Word16,Word32,Word64 ) +import GHC.TypeNats + ( Nat, type (-), type (<=?) ) + +-- half +import Numeric.Half + ( Half ) + +-- fir +import {-# SOURCE #-} Data.Product + ( HList ) +import {-# SOURCE #-} FIR.AST + ( AST ) +import FIR.AST.Type + ( AugType(Val, (:-->)) ) +import FIR.Prim.Array + ( Array,RuntimeArray ) +import FIR.Prim.RayTracing + ( AccelerationStructure, RayQuery ) +import {-# SOURCE #-} FIR.Prim.Struct + ( Struct ) +import Math.Linear + ( V,M ) + +------------------------------------------------------------ + +type NatVariadic + ( n :: Nat ) + ( a :: Type ) + ( b :: Type ) + = ( NatVariadic' n a b (1 <=? n) :: AugType ) + +type family NatVariadic' + ( n :: Nat ) + ( a :: Type ) + ( b :: Type ) + ( geq1 :: Bool ) + = ( r :: AugType ) + | r -> b + where + NatVariadic' n _ b 'False = Val b + NatVariadic' n a b 'True = Val a :--> NatVariadic (n-1) a b + +------------------------------------------------------------ + +type family AugListVariadic (as :: [AugType]) (b :: Type) = ( r :: AugType ) | r -> as b where + AugListVariadic '[] b = Val b + AugListVariadic (a ': as) b = a :--> AugListVariadic as b + +-- explicitly list all primitive types, to allow injectivity annotation +type family ListVariadic (as :: [Type]) (b :: Type) = (r :: Type) | r -> as b where + ListVariadic (a ': as) b = a -> ListVariadic as b + ListVariadic '[] () = () + ListVariadic '[] Bool = Bool + ListVariadic '[] Word = Word + ListVariadic '[] Word8 = Word8 + ListVariadic '[] Word16 = Word16 + ListVariadic '[] Word32 = Word32 + ListVariadic '[] Word64 = Word64 + ListVariadic '[] Int = Int + ListVariadic '[] Int8 = Int8 + ListVariadic '[] Int16 = Int16 + ListVariadic '[] Int32 = Int32 + ListVariadic '[] Int64 = Int64 + ListVariadic '[] Half = Half + ListVariadic '[] Float = Float + ListVariadic '[] Double = Double + ListVariadic '[] (V n a) = V n a + ListVariadic '[] (M m n a) = M m n a + ListVariadic '[] (Struct as) = Struct as + ListVariadic '[] (Array n a) = Array n a + ListVariadic '[] (RuntimeArray a) = RuntimeArray a + ListVariadic '[] (AST a) = AST a + ListVariadic '[] (a1,a2) = (a1,a2) + ListVariadic '[] (a1,a2,a3) = (a1,a2,a3) + ListVariadic '[] (a1,a2,a3,a4) = (a1,a2,a3,a4) + ListVariadic '[] (a1,a2,a3,a4,a5) = (a1,a2,a3,a4,a5) + ListVariadic '[] (a1,a2,a3,a4,a5,a6) = (a1,a2,a3,a4,a5,a6) + ListVariadic '[] (a1,a2,a3,a4,a5,a6,a7) = (a1,a2,a3,a4,a5,a6,a7) + ListVariadic '[] (a1,a2,a3,a4,a5,a6,a7,a8) = (a1,a2,a3,a4,a5,a6,a7,a8) + ListVariadic '[] (HList as) = HList as + ListVariadic '[] AccelerationStructure = AccelerationStructure + ListVariadic '[] RayQuery = RayQuery diff --git a/src/Data/Product.hs b/src/Data/Product.hs new file mode 100644 --- /dev/null +++ b/src/Data/Product.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Data.Product + +This module uses heterogeneous lists to define unbiased products needed by the type-level optics of this library. +-} + + +module Data.Product where + +-- base +import Data.Kind + ( Type ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- fir +import Data.Constraint.All + ( All ) +import Data.Type.List + ( KnownLength + , ZipCons + , SameLength + ) +import {-# SOURCE #-} FIR.Prim.Types + ( PrimTy ) + +---------------------------------------------------------------------- + +infixr 3 :> + +data HList (as :: [Type]) where + HNil :: HList '[] + (:>) :: a -> HList as -> HList (a ': as) + +instance Show (HList '[]) where + show _ = "HNil" +instance ( Show a, Show (HList as) ) => Show (HList (a ': as)) where + show (a :> as) = show a ++ " :> " ++ show as + +class KnownLength as => IsProduct (p :: Type) (as :: [Type]) {--- | p -> as ---} + where + fromHList :: HList as -> p + toHList :: p -> HList as + +instance KnownLength as => IsProduct (HList as) as where + fromHList = id + toHList = id + +-- TODO: refactor this using 'Data.Constraint.All' +data AreProductsDict js iss as where + NilProducts :: AreProductsDict '[] '[] as + ConsProducts + :: ( IsProduct j is + , All PrimTy is + , AreProducts js iss as + , SameLength is (Distribute iss as) + ) + => AreProductsDict (j ': js) (is ': iss) as + +class SameLength js iss + => AreProducts (js :: [Type]) (iss :: [[Type]]) (as :: [Type]) {--- | js -> iss ---} + where + productsDict :: AreProductsDict js iss as +instance AreProducts '[] '[] as where + productsDict = NilProducts +instance (IsProduct j is, AreProducts js iss as, SameLength is (Distribute iss as), All PrimTy is) + => AreProducts (j ': js) (is ': iss) as where + productsDict = ConsProducts + +type family MapHList (iss :: [[Type]]) = (as :: [Type]) | as -> iss where + MapHList '[] = '[] + MapHList (is ': iss) = HList is ': MapHList iss + +type family Distribute (iss :: [[Type]]) (as :: [Type]) = (jss :: [[Type]]) where + Distribute '[] '[] = '[] + Distribute '[] (a ': as) = '[] ': Distribute '[] as + Distribute (is ': iss) as = ZipCons is (Distribute iss as) + +distributeZipConsLemma1 + :: forall (a :: Type) (as :: [Type]) (ds :: [Type]) (dss :: [[Type]]) (es :: [Type]) (ess :: [[Type]]) + . ( SameLength es ess + , (ds ': dss) ~ Distribute (ZipCons es ess) (a ': as) + ) + => ( ds :~: es, dss :~: Distribute ess as ) +distributeZipConsLemma1 = ( unsafeCoerce Refl, unsafeCoerce Refl ) + +distributeZipConsLemma2 + :: forall (as :: [Type]) (is :: [Type]) (iss :: [[Type]]) + . ( SameLength is (Distribute iss as) ) + => ( ZipCons is (Distribute iss as) :~: Distribute (is ': iss) as ) +distributeZipConsLemma2 = unsafeCoerce Refl + +instance IsProduct a '[a] where + toHList x = x :> HNil + fromHList (x :> HNil) = x + +instance IsProduct (a1,a2) '[a1,a2] where + toHList (x1,x2) = (x1 :> x2 :> HNil) + fromHList (x1 :> x2 :> HNil) = (x1,x2) + +instance IsProduct (a1,a2,a3) '[a1,a2,a3] where + toHList (x1,x2,x3) = (x1 :> x2 :> x3 :> HNil) + fromHList (x1 :> x2 :> x3 :> HNil) = (x1,x2,x3) + +instance IsProduct (a1,a2,a3,a4) '[a1,a2,a3,a4] where + toHList (x1,x2,x3,x4) = (x1 :> x2 :> x3 :> x4 :> HNil) + fromHList (x1 :> x2 :> x3 :> x4 :> HNil) = (x1,x2,x3,x4) + +instance IsProduct (a1,a2,a3,a4,a5) '[a1,a2,a3,a4,a5] where + toHList (x1,x2,x3,x4,x5) = (x1 :> x2 :> x3 :> x4 :> x5 :> HNil) + fromHList (x1 :> x2 :> x3 :> x4 :> x5 :> HNil) = (x1,x2,x3,x4,x5) + +instance IsProduct (a1,a2,a3,a4,a5,a6) '[a1,a2,a3,a4,a5,a6] where + toHList (x1,x2,x3,x4,x5,x6) = (x1 :> x2 :> x3 :> x4 :> x5 :> x6 :> HNil) + fromHList (x1 :> x2 :> x3 :> x4 :> x5 :> x6 :> HNil) = (x1,x2,x3,x4,x5,x6) + +instance IsProduct (a1,a2,a3,a4,a5,a6,a7) '[a1,a2,a3,a4,a5,a6,a7] where + toHList (x1,x2,x3,x4,x5,x6,x7) = (x1 :> x2 :> x3 :> x4 :> x5 :> x6 :> x7 :> HNil) + fromHList (x1 :> x2 :> x3 :> x4 :> x5 :> x6 :> x7 :> HNil) = (x1,x2,x3,x4,x5,x6,x7) + +instance IsProduct (a1,a2,a3,a4,a5,a6,a7,a8) '[a1,a2,a3,a4,a5,a6,a7,a8] where + toHList (x1,x2,x3,x4,x5,x6,x7,x8) = (x1 :> x2 :> x3 :> x4 :> x5 :> x6 :> x7 :> x8 :> HNil) + fromHList (x1 :> x2 :> x3 :> x4 :> x5 :> x6 :> x7 :> x8 :> HNil) = (x1,x2,x3,x4,x5,x6,x7,x8) diff --git a/src/Data/Product.hs-boot b/src/Data/Product.hs-boot new file mode 100644 --- /dev/null +++ b/src/Data/Product.hs-boot @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Product where + +-- base +import Data.Kind + ( Type ) + +-- fir +import Data.Type.List + ( KnownLength ) + +---------------------------------------------------------------------- + +infixr 3 :> + +data HList (as :: [Type]) where + HNil :: HList '[] + (:>) :: a -> HList as -> HList (a ': as) + +class KnownLength as => IsProduct (p :: Type) (as :: [Type]) {--- | p -> as ---} + where + fromHList :: HList as -> p + toHList :: p -> HList as diff --git a/src/Data/Type/Error.hs b/src/Data/Type/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Error.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Data.Type.Error + +Helper functions to manage custom type-errors: throwing them, combining them, etc. +-} + +module Data.Type.Error where + +-- base +import Data.Kind + ( Constraint ) +import GHC.TypeLits + ( TypeError, ErrorMessage((:$$:)) ) + +---------------------------------------------------------------------- + +type family Try ( x :: Either ErrorMessage a ) :: a where + Try (Left err) = TypeError err + Try (Right a ) = a + +type family IsRight ( x :: Either ErrorMessage a ) :: Constraint where + IsRight (Left err) = TypeError err + IsRight _ = () + +type family IfLeft ( x :: Either e a ) ( y :: Either e a ) :: Either e a where + IfLeft (Left _) y = y + IfLeft x _ = x + +type family And ( x :: Either ErrorMessage r ) ( y :: Either ErrorMessage r ) :: Either ErrorMessage r where + And (Right _) y = y + And (Left x) (Left y) = Left (x :$$: y) + And (Left x) _ = Left x + +type family All ( xs :: [ Either ErrorMessage r ] ) :: Either ErrorMessage r where + All '[] = Right '() + All (x ': xs) = x `And` (All xs) + +data family Dummy1 :: k +data family Dummy2 :: k + +type family Assert (x :: k) (y :: l) :: l where + Assert Dummy1 _ = Dummy2 + Assert _ y = y diff --git a/src/Data/Type/Known.hs b/src/Data/Type/Known.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Known.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Data.Type.Known + +This module provides a simple type class for reification (turning type-level data into value-level data). + +This allows programs to perform type-level computations (e.g. to perform validation at compile time), +and at the end turn this type-level data back into value-level data to be used e.g. by the code generator. + +This is a one way process: these are not singletons. See "FIR.Prim.Types" for the singletons this library uses internally. + +Note that some instances are tailored to this library: type-level literals 'Symbol' are turned into 'ShortText', +and type-level natural numbers 'Nat' are turned into 'Word32'. +-} + + +module Data.Type.Known where + +-- base +import Data.Kind + ( Type ) +import Data.Proxy + ( Proxy(Proxy) ) +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( Symbol, KnownSymbol, symbolVal ) +import GHC.TypeNats + ( Nat, KnownNat, natVal ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + +-- fir +import Data.Type.Map + ( (:->)((:->)) ) + +-------------------------------------------------- + +class Demotable k where + type Demote k = (d :: Type) | d -> k + +class Demotable k => Known (k :: Type) (a :: k) where + known :: Demote k + +-- make the kind parameter invisible +type KindOf (a :: k) = k +knownValue :: forall a. Known (KindOf a) a => Demote (KindOf a) +knownValue = known @(KindOf a) @a + +instance Demotable Symbol where + type Demote Symbol = ShortText +instance KnownSymbol k => Known Symbol k where + known = ShortText.pack (symbolVal @k Proxy) + +instance Demotable Nat where + type Demote Nat = Word32 +instance KnownNat n => Known Nat n where + known = fromIntegral (natVal @n Proxy) + +instance Demotable Bool where + type Demote Bool = Bool + +instance Known Bool 'False where + known = False +instance Known Bool 'True where + known = True + +instance Demotable k => Demotable (Maybe k) where + type Demote (Maybe k) = Maybe (Demote k) +instance Demotable k => Known (Maybe k) 'Nothing where + known = Nothing +instance Known k a => Known (Maybe k) ('Just a) where + known = Just ( known @k @a ) + +instance Demotable () where + type Demote () = () + +instance Known () '() where + known = () + +instance (Demotable k, Demotable l) => Demotable (k,l) where + type Demote (k,l) = (Demote k, Demote l) +instance (Known k a, Known l b) => Known (k,l) '(a,b) where + known = ( known @k @a, known @l @b ) + +instance (Demotable k, Demotable l, Demotable m) => Demotable (k,l,m) where + type Demote (k,l,m) = (Demote k, Demote l, Demote m) +instance (Known k a, Known l b, Known m c) => Known (k,l,m) '(a,b,c) where + known = ( known @k @a, known @l @b, known @m @c ) + +instance Demotable k => Demotable [k] where + type Demote [k] = [Demote k] +instance Demotable k => Known [k] '[] where + known = [] +instance ( Known k a, Known [k] as ) => Known [k] (a ': as) where + known = known @k @a : known @[k] @as + +instance ( Demotable k, Demotable v ) => Demotable (k :-> v) where + type Demote (k :-> v) = Demote k :-> Demote v +instance ( Known k a, Known v b ) => Known (k :-> v) (a ':-> b) where + known = known @k @a :-> known @v @b diff --git a/src/Data/Type/LazyEquality.hs b/src/Data/Type/LazyEquality.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/LazyEquality.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: Data.Type.LazyEquality + +This module defines an alternative version of 'Data.Type.Equality.==', +for which @a == a@ always reduces to 'True'. +-} + +module Data.Type.LazyEquality + ( LazyEq ) + where + +------------------------------------------------------- + +infix 4 `LazyEq` + +-- Alternative version of 'Data.Type.Equality.=='. +-- Ensures that @a == a@ reduces to True for any argument @a@. +-- +-- See "Data.Type.Equality.==", which explains the trade-off. +type family (a :: k) `LazyEq` (b :: k) :: Bool where + a `LazyEq` a = 'True + _ `LazyEq` _ = 'False diff --git a/src/Data/Type/List.hs b/src/Data/Type/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/List.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Data.Type.List + +Operations on type-level lists, such as concatenation and length. +-} + +module Data.Type.List + ( type (:++:) + , Elem, AtIndex + , Head, Tail, MapTail + , Init, Last + , Join + , MapSingleton + , Zip, ExactZip, ZipCons + , Replicate + , Length + , SLength(SZero, SSucc) + , KnownLength(sLength), sLengthVal + , SameLength(sSameLength) + , SSameLength(SSameZero,SSameSucc) + , Postpend + -- re-exports + , Snoc, Reverse + ) where + +-- base +import GHC.TypeLits + ( TypeError, ErrorMessage(..) ) +import GHC.TypeNats + ( Nat, type (+), type (-) ) + +-- fir +import Data.Type.Snoc -- for re-export + ( Snoc, Reverse ) + +------------------------------------------------ +-- functionality to deal with type-level lists + +infixr 6 :++: + +type family (:++:) (as :: [k]) (bs :: [k]) :: [k] where + '[] :++: bs = bs + (a ': as) :++: bs = a ': ( as :++: bs ) + +infix 4 `Elem` + +type family Elem (x :: k) (as :: [k]) :: Bool where + Elem _ '[] = 'False + Elem x (x ': _ ) = 'True + Elem x (_ ': as) = Elem x as + +type family AtIndex (i :: Nat) (as :: [k]) :: Maybe k where + AtIndex _ '[] = Nothing + AtIndex 0 (k ': _ ) = Just k + AtIndex i (_ ': ks) = AtIndex (i-1) ks + +type family Head (x :: [k]) :: k where + Head (x ': _) = x + +type family Tail (x :: [k]) :: [k] where + Tail (_ ': xs) = xs + +type family Last (x :: [k]) :: k where + Last '[x] = x + Last (x ': xs) = Last xs + +type family Init (x :: [k]) :: [k] where + Init '[x] = '[] + Init (x ': xs) = x ': Init xs + +type family MapTail (x :: [[k]]) :: [[k]] where + MapTail '[] = '[] + MapTail (xs ': xss) = Tail xs ': MapTail xss + +type family Join (xss :: [[k]]) :: [k] where + Join '[] = '[] + Join (xs ': xss) = xs :++: Join xss + +type family MapSingleton (as :: [k]) :: [[k]] where + MapSingleton '[] = '[] + MapSingleton (a ': as) = (a ': '[]) ': MapSingleton as + +type family Zip (is :: [k]) (js :: [k]) :: [k] where + Zip '[] js = js + Zip is '[] = is + Zip (i ': is) (j ': js) = (i,j) ': Zip is js + +type family ExactZip (msg :: ErrorMessage) (as :: [k]) (bs :: [k]) :: [k] where + ExactZip _ '[] '[] = '[] + ExactZip msg (a ': as) (b ': bs) = (a,b) ': ExactZip msg as bs + ExactZip msg _ _ = TypeError msg + +type family ZipCons (as :: [k]) (bss :: [[k]]) = (r :: [[k]]) | r -> as bss where + ZipCons '[] '[] = '[] + ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss + +type family Replicate (n :: Nat) (a :: k) :: [k] where + Replicate 0 _ = '[] + Replicate n a = a ': Replicate (n-1) a + +type family Length (as :: [k]) :: Nat where + Length '[] = 0 + Length (_ ': as) = 1 + Length as + +data SLength (is :: [k]) where + SZero :: SLength '[] + SSucc :: SLength is -> SLength (i ': is) + +class KnownLength (is :: [k]) where + sLength :: SLength is + +instance KnownLength '[] where + sLength = SZero + +instance KnownLength is => KnownLength (i ': is) where + sLength = SSucc ( sLength @_ @is ) + +sLengthVal :: SLength is -> Int +sLengthVal SZero = 0 +sLengthVal (SSucc i) = 1 + sLengthVal i + +data SSameLength (is :: [k]) (js :: [l]) where + SSameZero :: SSameLength '[] '[] + SSameSucc :: SSameLength is js -> SSameLength (i ': is) (j ': js) + +class SameLength (is :: [k]) (js :: [l]) where + sSameLength :: SSameLength is js +instance SameLength '[] '[] where + sSameLength = SSameZero +instance SameLength is js => SameLength (i ': is) (j ': js) where + sSameLength = SSameSucc ( sSameLength @_ @_ @is @js ) + +infixl 4 `Postpend` +-- Non-injective type family for post-pending. +-- +-- Prefer using 'Data.Type.Snoc.Snoc' to retain injectivity. +-- +-- (Note that this sometimes gives GHC trouble with constraint solving...) +type family Postpend (as :: [k]) (b :: k) :: [k] where + Postpend '[] b = '[ b ] + Postpend (a ': as) b = a ': Postpend as b diff --git a/src/Data/Type/Map.hs b/src/Data/Type/Map.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Map.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Data.Type.Map + +Simple type-level maps (association lists). +-} + +module Data.Type.Map where + +-- base +import Data.Type.Bool + ( If ) +import GHC.TypeLits + ( TypeError, ErrorMessage(..) ) + +-- fir +import Data.Type.POrd + ( POrd(Compare, (:<)) ) + +------------------------------------------------ +-- barebones type-level map functionality + +infixr 4 :-> +data (:->) k v = k :-> v + deriving stock ( Eq, Show ) + +-- this synonym should only be used when we are working +-- with lists that are known to be ordered +-- (assumes keys are an instance of POrd) +type Map k v = [k :-> v] + +type family Key (a :: (k :-> v)) :: k where + Key (k ':-> _) = k + +type family Value (a :: (k :-> v)) :: v where + Value (_ ':-> v) = v + +type family Keys (i :: [k :-> v]) :: [k] where + Keys '[] = '[] + Keys (kv ': kvs) = Key kv ': Keys kvs + +type family Values (i :: [k :-> v]) :: [v] where + Values '[] = '[] + Values (kv ': kvs) = Value kv ': Values kvs + +-- looks through the whole list always, in case the list is not sorted +type family Lookup (s :: k) (i :: [k :-> v]) :: Maybe v where + Lookup _ '[] = 'Nothing + Lookup k ((k ':-> a) ': _) = 'Just a + Lookup k (_ ': b) = Lookup k b + +type family LookupKey (s :: k) (i :: [k :-> v]) :: Maybe k where + LookupKey _ '[] = 'Nothing + LookupKey k ((k ':-> _) ': _) = 'Just k + LookupKey k (_ ': b) = LookupKey k b + +-- | Insert a key/value pair in an already-sorted map. +-- +-- Throws an error if the key is already present. +type family Insert (s :: k) (t :: v) (i :: Map k v) :: Map k v where + Insert k v '[] = '[ k ':-> v ] + Insert k v ((k ':-> a) ': _) = + TypeError + ( Text "Duplicate key: " + :$$: ShowType '[ (k ':-> v), (k ':-> a) ] + ) + Insert k v ((l ':-> a) ': b) = + If ( k :< l ) + ( (k ':-> v) ': (l ':-> a) ': b ) + ( (l ':-> a) ': Insert k v b ) + +-- | Insert a key/value pair in an already-sorted map. +-- +-- If a value already exists with that key, it gets overwritten with the new value. +type family InsertOverwriting (s :: k) (t :: v) (i :: Map k v) :: Map k v where + InsertOverwriting k v '[] = '[ k ':-> v ] + InsertOverwriting k v ((k ':-> a) ': b) = (k ':-> v) ': b + InsertOverwriting k v ((l ':-> a) ': b) = + If ( k :< l ) + ( (k ':-> v) ': (l ':-> a) ': b ) + ( (l ':-> a) ': InsertOverwriting k v b ) + +type family InsertWithAppend ( key :: k ) ( val :: v ) ( map :: Map k [v] ) :: Map k [v] where + InsertWithAppend key val '[] = '[ key ':-> '[ val ] ] + InsertWithAppend key val ( ( k ':-> vals ) ': kvs ) = + InsertWithAppendWithComparison key val k vals kvs ( Compare key k ) + +type family InsertWithAppendWithComparison ( key :: k ) ( val :: v ) ( key' :: k ) ( vals :: [v] ) ( rest :: Map k [v] ) ( comp :: Ordering ) :: Map k [v] where + InsertWithAppendWithComparison key val key' vals rest LT = + ( ( key ':-> '[val] ) ': ( key' ':-> vals ) ': rest ) + InsertWithAppendWithComparison key val key' vals rest EQ = + ( ( key ':-> ( val ': vals ) ) ': rest ) + InsertWithAppendWithComparison key val key' vals rest GT = + ( ( key' ':-> vals ) ': InsertWithAppend key val rest ) + + +type family Union (i :: Map k v) (j :: Map k v) :: Map k v where + Union i '[] = i + Union i ( (k ':-> a) ': b) = Union (Insert k a i) b + +type family UnionWithAppend (i :: Map k [v]) (j :: Map k [v]) :: Map k [v] where + UnionWithAppend i '[] = i + UnionWithAppend '[] i = i + UnionWithAppend ((k1 ':-> '[]) ': kvs1) i = UnionWithAppend kvs1 i + UnionWithAppend ((k1 ':-> val ': vals1) ': kvs1) ( ( k2 ':-> vals2 ) ': kvs2 ) = + UnionWithAppend ((k1 ':-> vals1) ': kvs1) (InsertWithAppendWithComparison k1 val k2 vals2 kvs2 (Compare k1 k2)) + +type family Delete (s :: k) (is :: Map k v) :: Map k v where + Delete _ '[] = '[] + Delete k ( (k ':-> _) ': is) = is -- assumes there are no duplicates + Delete k ( i ': is) = i ': Delete k is + +type family Remove (i :: Map k v) (j :: Map k v) :: Map k v where + Remove '[] j = j + Remove ( (k ':-> _) ': i) j = Remove i (Delete k j) + +type family InsertionSort (i :: [k :-> v]) :: Map k v where + InsertionSort '[] = '[] + InsertionSort ((k ':-> v) : l) = Insert k v (InsertionSort l) + +type family ZipValue (i :: [k]) (x :: v) :: Map k v where + ZipValue '[] _ = '[] + ZipValue (a ': as) x = ( (a ':-> x) ': ZipValue as x ) + +type family LookupAndLookup (key1 :: k1) (key2 :: k2) (map :: Map k1 (Map k2 v)) :: Maybe v where + LookupAndLookup key1 key2 map = LookupAndLookupFrom key2 (Lookup key1 map) + +type family LookupAndLookupFrom (key2 :: k2) (lk :: Maybe (Map k2 v)) :: Maybe b where + LookupAndLookupFrom _ Nothing = Nothing + LookupAndLookupFrom key2 (Just map) = Lookup key2 map + +type family InsertWithInsert (key1 :: k1) (key2 :: k2) (val :: v) (map :: Map k1 (Map k2 v)) :: Map k1 (Map k2 v) where + InsertWithInsert key1 key2 val '[] = '[ key1 ':-> '[ key2 ':-> val ] ] + InsertWithInsert key1 key2 val ((key1 ':-> map) ': rest) = ( key1 ':-> Insert key2 val map ) ': rest + InsertWithInsert key1 key2 val ((key ':-> map) ': rest) = + If (key1 :< key) + ((key1 ':-> '[ key2 ':-> val ]) ': (key ':-> map) ': rest) + ((key ':-> map) ': InsertWithInsert key1 key2 val rest) diff --git a/src/Data/Type/Maybe.hs b/src/Data/Type/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Maybe.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module: Data.Type.Maybe + +Type families for manipulating 'Maybe'. +-} + +module Data.Type.Maybe + ( FromMaybe, FromJust, IsJust, IsNothing + , IfNothingThen, SequenceMaybe + ) + where + +-- base +import GHC.TypeLits + ( TypeError, ErrorMessage ) + +------------------------------------------------ + +type family FromMaybe (x :: Maybe k) (y :: k) :: k where + FromMaybe (Just x) _ = x + FromMaybe Nothing y = y + +type family FromJust (x :: Maybe k) (y :: ErrorMessage) :: k where + FromJust (Just x) _ = x + FromJust Nothing err = TypeError err + +type family IsJust (x :: Maybe k) :: Bool where + IsJust (Just _) = True + IsJust Nothing = False + +type family IsNothing (x :: Maybe k) :: Bool where + IsNothing Nothing = True + IsNothing (Just _ ) = False + +type family IfNothingThen (x :: Maybe k) (y :: Maybe k) :: Maybe k where + IfNothingThen (Just x) _ = Just x + IfNothingThen Nothing y = y + +type family SequenceMaybe (m :: Maybe [a]) :: [a] where + SequenceMaybe Nothing = '[] + SequenceMaybe (Just as) = as diff --git a/src/Data/Type/Nat.hs b/src/Data/Type/Nat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Nat.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Data.Type.Maybe + +This module defines some arithmetic operations on type-level natural numbers. +-} + +module Data.Type.Nat where + +-- base +import GHC.TypeNats + ( Nat, Div, Log2 + , type (+), type (-), type (*), type (^) + ) + +-------------------------------------------------------------------------- + +-- | Round @n@ up to the nearest multiple of @r@. +type RoundUp n r + = ( ( n + r - 1 ) `Div` r ) * r + +type family NextPositivePowerOf2 (n :: Nat) :: Nat where + NextPositivePowerOf2 0 = 1 + NextPositivePowerOf2 n = NextPowerOf2 n + +type family NextPowerOf2 (n :: Nat) :: Nat where + NextPowerOf2 0 = 0 + NextPowerOf2 1 = 1 + NextPowerOf2 n = 2 ^ ( Log2 (n-1) + 1 ) -- Log2 x is actually Floor ( Log2 x ) + +type family Succ ( n :: Nat ) = ( m :: Nat ) | m -> n where + Succ 0 = 1 + Succ 1 = 2 + Succ 2 = 3 + Succ 3 = 4 + Succ 4 = 5 + Succ 5 = 6 + Succ 6 = 7 + Succ 7 = 8 + Succ 8 = 9 + Succ 9 = 10 + Succ 10 = 11 + Succ 11 = 12 + Succ 12 = 13 + Succ 13 = 14 + Succ 14 = 15 + Succ 15 = 16 + Succ 16 = 17 + Succ 17 = 18 + Succ 18 = 19 + Succ 19 = 20 + Succ 20 = 21 + Succ 21 = 22 + Succ 22 = 23 + Succ 23 = 24 + Succ 24 = 25 + Succ 25 = 26 + Succ 26 = 27 + Succ 27 = 28 + Succ 28 = 29 + Succ 29 = 30 + Succ 30 = 31 + Succ 31 = 32 + Succ 32 = 33 + Succ 33 = 34 + Succ 34 = 35 + Succ 35 = 36 + Succ 36 = 37 + Succ 37 = 38 + Succ 38 = 39 + Succ 39 = 40 + Succ 40 = 41 + Succ 41 = 42 + Succ 42 = 43 + Succ 43 = 44 + Succ 44 = 45 + Succ 45 = 46 + Succ 46 = 47 + Succ 47 = 48 + Succ 48 = 49 + Succ 49 = 50 + Succ 50 = 51 + Succ 51 = 52 + Succ 52 = 53 + Succ 53 = 54 + Succ 54 = 55 + Succ 55 = 56 + Succ 56 = 57 + Succ 57 = 58 + Succ 58 = 59 + Succ 59 = 60 + Succ 60 = 61 + Succ 61 = 62 + Succ 62 = 63 + Succ 63 = 64 + Succ 64 = 65 diff --git a/src/Data/Type/POrd.hs b/src/Data/Type/POrd.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/POrd.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Data.Type.POrd + +Promotion of the 'Ord' type class. +-} + +module Data.Type.POrd where + +-- base +import Data.Type.Bool + ( If, Not ) +import GHC.TypeLits + ( Symbol, CmpSymbol ) +import GHC.TypeNats + ( Nat, CmpNat, type (+), type (-) ) + +-- fir +import Data.Type.LazyEquality + ( LazyEq ) + +------------------------------------------------------------------------------- + +infix 4 :< +infix 4 :> +infix 4 :<= +infix 4 :>= +infix 4 `Compare` + +class POrd a where + type Compare (x :: a) (y :: a) :: Ordering + type (x :: a) :< (y :: a) :: Bool + type x :< y = Compare x y `LazyEq` LT + type (x :: a) :> (y :: a) :: Bool + type x :> y = Compare x y `LazyEq` GT + type (x :: a) :<= (y :: a) :: Bool + type x :<= y = Not (Compare x y `LazyEq` GT) + type (x :: a) :>= (y :: a) :: Bool + type x :>= y = Not (Compare x y `LazyEq` LT) + type Max (x :: a) (y :: a) :: a + type Max x y = If (x :< y) y x + type Min (x :: a) (y :: a) :: a + type Min x y = If (x :> y) y x + +instance POrd Symbol where + type Compare x y = CmpSymbol x y + +instance POrd Nat where + type Compare x y = CmpNat x y + type Max x y = MaxNat x y + +-- | The maximum of two natural numbers. +-- +-- The equations for @0@ hold off reduction until both arguments +-- have been evaluated, which avoids duplicating unevaluated arguments. +type family MaxNat (x :: Nat) (y :: Nat) :: Nat where + MaxNat 0 y = y + MaxNat x 0 = x + MaxNat x y = If (x :< y) y x + +instance ( POrd a, POrd b ) => POrd (a,b) where + type Compare p1 p2 = Lexicographic2 p1 p2 + +type family Lexicographic2 (p1 :: (a,b)) (p2 :: (a,b)) :: Ordering where + Lexicographic2 '(x ,y1) '(x ,y2) = Compare y1 y2 + Lexicographic2 '(x1,_) '(x2,_) = Compare x1 x2 + +instance ( POrd a, POrd b, POrd c ) => POrd (a,b,c) where + type Compare t1 t2 = Lexicographic3 t1 t2 + +type family Lexicographic3 (t1 :: (a,b,c)) (t2 :: (a,b,c)) :: Ordering where + Lexicographic3 '(x ,y ,z1) '(x ,y ,z2) = Compare z1 z2 + Lexicographic3 '(x ,y1,_ ) '(x ,y2,_ ) = Compare y1 y2 + Lexicographic3 '(x1,_ ,_ ) '(x2,_ ,_ ) = Compare x1 x2 + + +class POrd a => PEnum a where + type Succ (x :: a) :: a + type Pred (x :: a) :: a + type ToEnum (i :: Nat) :: a + type FromEnum (x :: a) :: Nat + type EnumFromTo (x :: a) (y :: a) :: [a] + type EnumFromTo x y + = EnumFromToDefault x y (x :> y) + type EnumFromOfCount (x :: a) (i :: Nat) :: [a] + type EnumFromOfCount x i + = EnumFromOfCountDefault x i + +type family EnumFromToDefault (x :: a) (y :: a) (x_gt_y :: Bool) :: [a] where + EnumFromToDefault _ _ 'True = '[] + EnumFromToDefault x y 'False = x ': EnumFromTo (Succ x) y + +type family EnumFromOfCountDefault (x :: a) (i :: Nat) :: [a] where + EnumFromOfCountDefault _ 0 = '[] + EnumFromOfCountDefault x i = x ': EnumFromOfCountDefault (Succ x) (Pred i) + +instance PEnum Nat where + type Succ x = x + 1 + type Pred x = x - 1 + type ToEnum x = x + type FromEnum x = x diff --git a/src/Data/Type/Snoc.hs b/src/Data/Type/Snoc.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/Snoc.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Data.Type.Snoc + +Type-level snoc lists, providing injective type families 'Snoc' and 'Reverse'. + +(c) Artem Chirkin +-} + +module Data.Type.Snoc where + + +type Snoc (ns :: [k]) (n :: k) = GetSnoc (DoSnoc ns n) +type Reverse (xs :: [k]) = Reversed (DoReverse xs) + +data Snocing k = SSingle k | Snocing [k] + +type family DoSnoc (xs :: [k]) (z::k) = (ys :: Snocing k) | ys -> xs z where + DoSnoc '[] x = 'SSingle x + DoSnoc (x ': xs :: [k]) (y :: k) = ('Snocing (x ': GetSnoc (DoSnoc xs y) :: [k]) :: Snocing k) + +type family GetSnoc (xs :: Snocing k) = (ys :: [k]) | ys -> xs where + GetSnoc ('SSingle x) = '[x] + GetSnoc ('Snocing (y ': x ': xs)) = y ': x ': xs + +data Reversing k = REmpty | Reversing [k] + +type family Reversed (ts :: Reversing k) = (rs :: [k]) | rs -> ts where + Reversed 'REmpty = '[] + Reversed ('Reversing (x ': xs)) = x ': xs + +type family DoReverse (as :: [k]) = (rs :: Reversing k) | rs -> as where + DoReverse '[] = 'REmpty + DoReverse (a ': as) = 'Reversing (Reversed (DoReverse as) `Snoc` a) diff --git a/src/Data/Type/String.hs b/src/Data/Type/String.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/String.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Data.Type.String + +Type-level manipulation of symbols and lists of symbols. + +Includes operations to convert between type-level natural numbers +and type-level symbols. + +Credit to Csongor Kiss for the underlying techniques +(see https://kcsongor.github.io/symbol-parsing-haskell/). +-} + +module Data.Type.String + ( + -- * Type-level ToList + CompareWith + , LookupTree(..) + , LookupChars, LookupPrefixedChars + -- * Converting between 'Symbol' and 'Nat' + -- ** Reading symbols as natural numbers + , ReadNat, ReadPrefixedNat + -- ** Showing natural numbers as symbols + , ShowNat + ) where + +-- base +import GHC.TypeLits + ( Symbol, CmpSymbol, AppendSymbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat + , type (+), type (*) + , Div, Mod + ) + +------------------------------------------------------------------------------------------- +-- Type-level ToList + +-- | Compare a prefixed symbol with a specified symbol. +-- +-- Note that the comparison is done relative to the last argument. For instance: +-- +-- * @ CompareWith "prefix" "1" "prefix7" = GT @ +-- * @ CompareWith "prefix" "7" "prefix7" = EQ @ +-- * @ CompareWith "prefix" "9" "prefix7" = LT @ +type family CompareWith (prefix :: Symbol) (i :: Symbol) (k :: Symbol) :: Ordering where + CompareWith prefix i k = k `CmpSymbol` (prefix `AppendSymbol` i) + +-- | Character lookup tree. +-- +-- Used at the type level as a data kind. +data LookupTree a + = EnsureGTE a (LookupTree a) + | EnsureLT a (LookupTree a) + | Node a a (LookupTree a) (LookupTree a) + | Leaf a + | Return + + +-- | Obtain the leading list of characters that succeed lookup. +-- +-- For instance, using the numeric digit tree 'DigitTree', one has: +-- +-- @ LookupChars DigitTree "127foo89" = '[ "1", "2", "7" ] @ +type family LookupChars (tree :: LookupTree Symbol) (k :: Symbol) :: [Symbol] where + LookupChars tree k = LookupPrefixedChars tree "" k + +-- | Same as 'LookupChars', but allows a prefix. +-- +-- @ LookupPrefixedChars DigitTree "foo" "foo34bar7" = '[ "3", "4" ] @ +type family LookupPrefixedChars + ( tree :: LookupTree Symbol ) + ( prefix :: Symbol ) + ( k :: Symbol ) + :: [Symbol] + where + LookupPrefixedChars tree prefix k + = LookupPrefixedCharsFrom tree tree prefix k + +-- Recursively traverse the lookup tree. +type family LookupPrefixedCharsFrom + ( tree :: LookupTree Symbol ) + ( curr :: LookupTree Symbol ) + ( prefix :: Symbol ) + ( k :: Symbol ) + :: [Symbol] + where + LookupPrefixedCharsFrom tree (EnsureGTE min subtree) prefix k + = LookupEnsureGTE (CompareWith prefix min k) tree subtree prefix k + LookupPrefixedCharsFrom tree (EnsureLT max subtree) prefix k + = LookupEnsureLT (CompareWith prefix max k) tree subtree prefix k + LookupPrefixedCharsFrom tree (Node min max left right) prefix k + = NodeLookup tree left right prefix k min max (CompareWith prefix min k) (CompareWith prefix max k) + LookupPrefixedCharsFrom tree (Leaf l) prefix k + = l ': LookupPrefixedChars tree (prefix `AppendSymbol` l) k + LookupPrefixedCharsFrom tree Return _ k + = '[ k ] + +type family LookupEnsureGTE + ( cmp :: Ordering ) + ( tree :: LookupTree Symbol ) + ( subtree :: LookupTree Symbol ) + ( prefix :: Symbol ) + ( k :: Symbol ) + :: [Symbol] where + LookupEnsureGTE 'LT _ _ _ _ = '[] + LookupEnsureGTE _ tree subtree prefix k = LookupPrefixedCharsFrom tree subtree prefix k + + +type family LookupEnsureLT + ( cmp :: Ordering ) + ( tree :: LookupTree Symbol ) + ( subtree :: LookupTree Symbol ) + ( prefix :: Symbol ) + ( k :: Symbol ) + :: [Symbol] where + LookupEnsureLT 'LT tree subtree prefix k = LookupPrefixedCharsFrom tree subtree prefix k + LookupEnsureLT _ _ _ _ _ = '[] + +type family NodeLookup + ( tree :: LookupTree Symbol ) + ( left :: LookupTree Symbol ) + ( right :: LookupTree Symbol ) + ( prefix :: Symbol ) + ( k :: Symbol ) + ( min :: Symbol ) + ( max :: Symbol ) + ( cmpMin :: Ordering ) + ( cmpMax :: Ordering ) + :: [Symbol] + where + NodeLookup tree left _ prefix k _ _ 'LT _ = LookupPrefixedCharsFrom tree left prefix k + NodeLookup tree _ right prefix k _ _ _ 'GT = LookupPrefixedCharsFrom tree right prefix k + NodeLookup tree _ _ prefix k _ max _ 'EQ = max ': LookupPrefixedChars tree (prefix `AppendSymbol` max) k + NodeLookup tree _ _ prefix k min _ _ _ = min ': LookupPrefixedChars tree (prefix `AppendSymbol` min) k + + +------------------------------------------------------------------------------------------- +-- Converting between 'Symbol' and 'Nat' + +-- Reading symbols as natural numbers + +-- | Lookup tree for numeric digits. +type DigitTree + = EnsureGTE "0" + ( EnsureLT ":" + ( Node "5" "6" + ( Node "3" "4" + ( Node "1" "2" + ( Leaf "0" ) + ( Leaf "2" ) + ) + ( Leaf "4" ) + ) + ( Node "7" "8" + ( Leaf "6" ) + ( Node "9" ":" + ( Leaf "8" ) + Return -- inaccessible + ) + ) + ) + ) + +-- | Reads a natural number from the leading digits of a literal. +-- +-- * @ ReadNat "0123" = 123 @ +-- * @ ReadNat "34abc" = 34 @ +-- * @ ReadNat "foo" = 0 @ +type family ReadNat (k :: Symbol) :: Nat where + ReadNat k = ReadPrefixedNat "" k + +-- | Same as 'ReadNat' but allows a prefix. +-- +-- * @ ReadPrefixedNat "foo1" "foo1099" = 99 @. +type family ReadPrefixedNat (prefix :: Symbol) (k :: Symbol) :: Nat where + ReadPrefixedNat prefix k + = FromDecimalDigitsAcc + 0 + ( LookupPrefixedChars DigitTree prefix k ) + +-- | Read an individual digit. +type family ReadDigit (d :: Symbol) :: Nat where + ReadDigit "0" = 0 + ReadDigit "1" = 1 + ReadDigit "2" = 2 + ReadDigit "3" = 3 + ReadDigit "4" = 4 + ReadDigit "5" = 5 + ReadDigit "6" = 6 + ReadDigit "7" = 7 + ReadDigit "8" = 8 + ReadDigit "9" = 9 + ReadDigit x + = TypeError + ( Text "Cannot read digit: " :<>: ShowType x :<>: Text " is not a digit." ) + +-- Returns a natural number from a base-10 representation. +type family FromDecimalDigitsAcc (acc :: Nat) (ds :: [Symbol]) :: Nat where + FromDecimalDigitsAcc acc '[] = acc + FromDecimalDigitsAcc acc (d ': ds) + = FromDecimalDigitsAcc ( 10 * acc + ReadDigit d ) ds + +-- | Turn a type-level natural number into a type-level symbol. +type family ShowNat (n :: Nat) :: Symbol where + ShowNat 0 = "0" + ShowNat 1 = "1" + ShowNat 2 = "2" + ShowNat 3 = "3" + ShowNat 4 = "4" + ShowNat 5 = "5" + ShowNat 6 = "6" + ShowNat 7 = "7" + ShowNat 8 = "8" + ShowNat 9 = "9" + ShowNat n = ShowNat (n `Div` 10) `AppendSymbol` ShowNat (n `Mod` 10) diff --git a/src/Deriving/Base.hs b/src/Deriving/Base.hs new file mode 100644 --- /dev/null +++ b/src/Deriving/Base.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-| +Module: Deriving.Base + +This module defines the newtype 'Base', used with `deriving via` to name instances coming from the Haskell prelude. + +For instance (pun intended): + +> deriving via Base Float instance Floating Float +> deriving via Base Double instance Floating Double + +See "Math.Algebra.Class" for illustration. + +-} + +module Deriving.Base + ( Base(Base, runBase) ) + where + +import qualified Prelude + +newtype Base a = Base { runBase :: a } + +deriving via a instance Prelude.Eq a => Prelude.Eq (Base a) +deriving via a instance Prelude.Ord a => Prelude.Ord (Base a) + +deriving via a instance Prelude.Show a => Prelude.Show (Base a) +deriving via a instance Prelude.Read a => Prelude.Read (Base a) + +deriving via a instance Prelude.Enum a => Prelude.Enum (Base a) +deriving via a instance Prelude.Bounded a => Prelude.Bounded (Base a) diff --git a/src/FIR.hs b/src/FIR.hs new file mode 100644 --- /dev/null +++ b/src/FIR.hs @@ -0,0 +1,489 @@ +{-# OPTIONS_HADDOCK ignore-exports #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR +Description: @---@ __Main module, re-exports what's needed to write programs and compile to SPIR-V.__ + +This module re-exports the main functionality needed to use the library. + +For an overview of the library, refer to the project [__readme__](https://gitlab.com/sheaf/fir/tree/master/readme.md). + +To illustrate the syntax of this library, the example of a trivial fragment shader follows. + +@ +\{\-\# LANGUAGE BlockArguments \#\-\} -- cleaner syntax for 'do' blocks (optional) +\{\-\# LANGUAGE DataKinds \#\-\} -- for datatype promotion and type-level literals +\{\-\# LANGUAGE RebindableSyntax \#\-\} -- 'do' notation to create ASTs with indexed monads +\{\-\# LANGUAGE TypeApplications \#\-\} -- to specify type-level arguments +\{\-\# LANGUAGE TypeOperators \#\-\} -- for type operators such as ':->, which stands for key/value assignment + +import FIR +import Math.Linear -- for vectors + +-- Specify the input/output of the shader, with memory locations (and other interface parameters). +-- This consists of a type-level list of top-level definitions. +type FragmentDefs + = '[ "in_pos" ':-> Input '[ Location 0 ] (V 2 Float) -- input (varying) of type V 2 Float and memory location 0 + , "out_col" ':-> Output '[ Location 0 ] (V 4 Float) -- output (varying) of type V 4 Float and memory location 0 + , "image" ':-> Texture2D '[ DescriptorSet 0, Binding 0 ] (RGBA8 UNorm) -- input sampled image (provided as binding 0 of descriptor set 0) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment -- fragment shader stage (with the origin in the upper left corner) + ] + +fragment :: Module FragmentDefs () +fragment = + Module $ entryPoint \@"main" \@Fragment do + pos <- get \@"in_pos" + col <- use \@(ImageTexel "image") NilOps pos + put \@"out_col" col +@ + +Note the lens-like operations: + + - @'FIR.Syntax.Program.get' \@"in_pos"@ – equivalent to + @'FIR.Syntax.Program.use' \@(Name "in_pos")@ – obtains the shader input varying "in_pos". + This operation is similar to @get@ in a state monad, except that an additional binding name + is provided via a type application. + - @'FIR.Syntax.Program.use' \@(ImageTexel "image") NilOps pos@ samples the provided image + at coordinates @pos@. Additional image operands can be provided for this sampling operation, + such as an explicit level of detail or whether to use projective coordinates + (refer to the SPIR-V specification for further information concerning image operands). + - @'FIR.Syntax.Program.put' \@"out_col" col@ – equivalent to + @'FIR.Syntax.Program.assign' \@(Name "out_col") col@ – + sets the output value of the shader. + + +This fragment shader can then be compiled using: + +> compileTo filePath flags fragment + +where @filePath@ is the desired output filepath, and @flags@ is a list of 'CompilerFlag's. + + +More meaningful examples can be found in the (@fir-examples@ subdirectory)(https://gitlab.com/sheaf/fir/tree/master/fir-examples) +of the project's repository. + +-} + +module FIR + ( DrawableProgramAST(showAST, drawAST) + , CompilableProgram(compile, compileTo) + , CompilerFlag(..) + , ModuleBinary(..), ModuleRequirements(..) + , runCompilationsTH + + -- re-exports + , module Control.Monad.Indexed + , Control.Type.Optic.Optic + , Control.Type.Optic.ShowOptic + , (Control.Type.Optic.:*:), Control.Type.Optic.Prod, Control.Type.Optic.EndProd + , (Control.Type.Optic.:.:) + , Control.Type.Optic.OfType + , Control.Type.Optic.AnIndex + , Control.Type.Optic.Index + , Control.Type.Optic.Name + , Control.Type.Optic.ReifiedGetter(view) + , Control.Type.Optic.ReifiedSetter(set) + , Control.Type.Optic.ReifiedLens(over) + , module Data.Product + , module Data.Type.List + , (Data.Type.Map.:->)((:->)) + , module Data.Type.POrd + , AST, FIR.AST.Code, EGADT + , module FIR.AST.Type + , pattern (:$), pattern Lit, pattern Struct, pattern Array + -- image operands + , pattern NilOps, pattern Proj, pattern Dref, pattern Bias + , pattern LOD, pattern MinLOD, pattern Grad + , pattern ConstOffsetBy, pattern OffsetBy + , pattern Gather, pattern SampleNo + -- internal hlist + , pattern NilHList, pattern ConsHList + , FIR.AST.Syntactic(..) + , FIR.AST.SyntacticVal, FIR.AST.InternalType + , FIR.AST.HasUndefined(undefined) + , FIR.Binding.BindingsMap + , FIR.Binding.Var, FIR.Binding.Fun + , FIR.Binding.R + , FIR.Binding.W + , FIR.Binding.RW + , FIR.Definition.Definition + ( Function + , EntryPoint + ) + , FIR.Layout.Layout(..) + , FIR.Layout.Poke(..) + , FIR.Layout.pokeArray + , FIR.Layout.pokeArrayOff + , FIR.Layout.MemberOffset + , FIR.Layout.memberOffset + , FIR.Layout.roundUp + , FIR.Layout.nextAligned + , module FIR.Module + , module FIR.Pipeline + , module FIR.Prim.Array + , FIR.Prim.Image.ImageProperties(..) + , FIR.Prim.Image.Image + , FIR.Prim.Image.GatherInfo(..) + , module FIR.Prim.RayTracing + , module FIR.Prim.Struct + , FIR.Prim.Types.PrimTy + , FIR.Prim.Types.ScalarTy + , FIR.Prim.Types.IntegralTy + , FIR.Prim.Atomic.AtomicTy, FIR.Prim.Atomic.AtomicIntegralTy + , FIR.Prim.Types.PrimTyMap + , FIR.Prim.Types.HasOpaqueType + , FIR.ProgramState.ProgramState(ProgramState) + , FIR.ProgramState.FunctionContext(TopLevel) + , module FIR.Syntax.AST + , module FIR.Syntax.Complex + , module FIR.Syntax.IfThenElse + , module FIR.Syntax.Images + , module FIR.Syntax.Optics + , module FIR.Syntax.Option + , module FIR.Syntax.Program + , module FIR.Syntax.RayTracing + , module FIR.Syntax.Swizzle + , module FIR.Syntax.Synonyms + , module FIR.Validation.Bindings + , module FIR.Validation.CFG + , module FIR.Validation.Images + , module FIR.Validation.RayTracing + , module Math.Algebra.Class + , module Math.Algebra.GradedSemigroup + , module Math.Logic.Bits + , module Math.Logic.Class + , module SPIRV.Capability + , SPIRV.Control.Inlineability(..) + , SPIRV.Control.SideEffects(..) + , SPIRV.Control.FunctionControl + , SPIRV.Control.SelectionControl(..) + , SPIRV.Decoration.Decoration(..) + , SPIRV.ExecutionMode.ExecutionMode(..) + , SPIRV.ExecutionMode.InputVertices -- synonym of 'OutputVertices' for tessellation evaluation shaders + , module SPIRV.Extension + , SPIRV.Groups.GroupOperation(..) + , SPIRV.Stage.Vertex + , SPIRV.Stage.TessellationControl + , SPIRV.Stage.TessellationEvaluation + , SPIRV.Stage.Geometry + , SPIRV.Stage.Fragment + , SPIRV.Stage.Compute + , SPIRV.Stage.Stage(..) + , SPIRV.Stage.Shader(..) + , SPIRV.Stage.RayShader(..) + , SPIRV.Stage.MeshShader(..) + , SPIRV.Stage.ExecutionModel(..) + , SPIRV.Stage.RayGeneration + , SPIRV.Stage.Intersection + , SPIRV.Stage.AnyHit + , SPIRV.Stage.ClosestHit + , SPIRV.Stage.Miss + , SPIRV.Stage.Callable + , SPIRV.Storage.DataOrigin(..) + , module SPIRV.Synchronisation + , SPIRV.Version.Version(..) + -- image properties + , SPIRV.Image.Dimensionality(..) + , SPIRV.Image.HasDepth(..) + , SPIRV.Image.Arrayness(..) + , SPIRV.Image.MultiSampling(..) + , SPIRV.Image.ImageUsage(..) + , SPIRV.Image.ImageFormat(ImageFormat) + , SNorm, UNorm, F, I, UI + , pattern SNorm, pattern UNorm + , pattern F, pattern I, pattern UI + , RGBA32, RGBA16, RGBA8 + , RG32, RG16, RG8 + , R32, R16, R8 + , R11G11B10 + , RGB10A2 + , pattern RGBA32, pattern RGBA16, pattern RGBA8 + , pattern RG32, pattern RG16, pattern RG8 + , pattern R32, pattern R16, pattern R8 + , pattern R11G11B10 + , pattern RGB10A2 + + -- known + , Data.Type.Known.Known(..) + , Data.Type.Known.knownValue + + -- Re-export of prelude and related functions + , module FIR.Prelude + ) where + +-- base +import Data.Functor + ( ($>) ) +import GHC.Generics + ( Generic ) + +-- template-haskell +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH + +-- atomic-file-ops +import System.IO.AtomicFileOps + ( atomicReplaceFile ) + +-- bytestring +import qualified Data.ByteString.Lazy as ByteString + ( writeFile ) +import Data.ByteString.Lazy + ( ByteString ) + +-- containers +import Data.Set + ( Set ) + +-- directory +import System.Directory + ( doesFileExist ) + +-- generic-monoid +import Data.Monoid.Generic + ( GenericSemigroup(..), GenericMonoid(..) ) + +-- tree-view +import Data.Tree.View + ( showTree ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- variant +import Data.Variant.EGADT + ( EGADT ) + +-- fir +import CodeGen.CodeGen +import CodeGen.State +import Control.Arrow.Strength +import Control.Monad.Indexed +import Control.Type.Optic +import Data.Product +import Data.Type.Known +import Data.Type.List +import Data.Type.Map +import Data.Type.POrd +import FIR.AST +import FIR.AST.Type +import FIR.Binding +import FIR.Definition +import FIR.Layout +import FIR.Module +import FIR.Pipeline +import FIR.Prelude +import FIR.Prim.Array +import FIR.Prim.Image +import FIR.Prim.RayTracing + hiding ( pattern RayQuery ) +import FIR.Prim.Atomic +import FIR.Prim.Types +import FIR.Prim.Struct +import FIR.ProgramState +import FIR.Syntax.AST +import FIR.Syntax.Complex +import FIR.Syntax.IfThenElse +import FIR.Syntax.Images +import FIR.Syntax.Optics +import FIR.Syntax.Option +import FIR.Syntax.Program +import FIR.Syntax.RayTracing +import FIR.Syntax.Swizzle +import FIR.Syntax.Synonyms +import FIR.Validation.Bindings + ( Has, CanGet, CanPut + , ValidFunDef, ValidEntryPoint + , Embeddable + ) +import FIR.Validation.CFG + ( InLoop ) +import FIR.Validation.Images + ( ValidImageRead, ValidImageWrite ) +import FIR.Validation.RayTracing + ( CanTraceRay, CanExecuteCallable ) +import Instances.TH.Lift + ( ) -- Lift instances for ByteString, ShortText, Set +import Math.Algebra.Class +import Math.Algebra.GradedSemigroup +import Math.Logic.Bits +import Math.Logic.Class +import SPIRV.Capability +import qualified SPIRV.Capability as SPIRV +import SPIRV.Control +import SPIRV.Decoration +import SPIRV.ExecutionMode +import SPIRV.Extension +import qualified SPIRV.Extension as SPIRV +import SPIRV.Image hiding ( LODOperand(..), Operand(..) ) +import SPIRV.Groups +import SPIRV.Stage +import SPIRV.Storage +import SPIRV.Version +import qualified SPIRV.Version as SPIRV +import SPIRV.Synchronisation + +------------------------------------------------ + +-- | Functionality for drawing a program AST as a tree. +-- +-- Can be used on whole programs, or on snippets of code in the AST indexed monad. +class DrawableProgramAST prog where + showAST :: prog -> String + drawAST :: prog -> IO () + drawAST = putStrLn . showAST + +instance DrawableProgramAST (AST a) where + showAST = showTree . toTree +instance SyntacticVal a => DrawableProgramAST (Program i j a) where + showAST = showTree . toTree . toAST +instance DrawableProgramAST (Module def) where + showAST (Module prog) = showAST prog +instance DrawableProgramAST (ShaderModule name stage defs endState) where + showAST (ShaderModule prog) = showAST prog + +-- | Compiler flags. +data CompilerFlag + = NoCode -- ^ Don't emit any SPIR-V code. + | Debug -- ^ Include additional debug instructions, such as source-code line-number annotations and @debugPrintf@ output. + | Assert -- ^ Include additional assertions. + | SPIRV SPIRV.Version -- ^ SPIR-V version number (default: 1.5 for Vulkan, 1.2 for OpenCL). + deriving stock ( Prelude.Eq, Show ) + +updateContextFromFlags :: CGContext -> [ CompilerFlag ] -> CGContext +updateContextFromFlags = foldl updateContext + where + updateContext :: CGContext -> CompilerFlag -> CGContext + updateContext ctxt NoCode = ctxt { emittingCode = False } + updateContext ctxt Debug = ctxt { debugging = True } + updateContext ctxt Assert = ctxt { asserting = True } + updateContext ctxt (SPIRV ver) = ctxt { spirvVersion = ver } + +-- | Information about requirements for a given SPIR-V module, +-- such as which SPIR-V capabilities and extensions are needed. +-- +-- This information can be useful to compute Vulkan requirements. +data ModuleRequirements + = ModuleRequirements + { requiredCapabilities :: Set SPIRV.Capability + , requiredExtensions :: Set SPIRV.Extension + } + deriving stock ( Prelude.Eq, Show, Generic, TH.Lift ) + deriving Semigroup via GenericSemigroup ModuleRequirements + deriving Monoid via GenericMonoid ModuleRequirements + +-- | Newtype wrapper for the binary source of a SPIR-V module. +-- +-- This newtype emphasises the fact that module binaries are monolithic, +-- e.g. one can't combine binaries using '(<>)'. +newtype ModuleBinary = ModuleBinary { moduleBinary :: ByteString } + +-- | Functionality for compiling a program into a SPIR-V module. +class CompilableProgram prog where + compile :: [CompilerFlag] -> prog -> IO ( Either ShortText ( Maybe ModuleBinary, ModuleRequirements ) ) + compileTo :: FilePath -> [CompilerFlag] -> prog -> IO ( Either ShortText ModuleRequirements ) + compileTo filePath flags prog = + compile flags prog Prelude.>>= \case + Left err + -> Prelude.pure (Left err) + Right (mbBin, reqs) + | Just (ModuleBinary bytes) <- mbBin + -> writeBytesAtomically bytes $> Right reqs + | otherwise + -> Prelude.pure ( Right reqs ) + where + writeBytesAtomically :: ByteString -> IO () + writeBytesAtomically bytes = + doesFileExist filePath Prelude.>>= \case + False -> ByteString.writeFile filePath bytes + True -> atomicReplaceFile Nothing filePath bytes + +instance ( KnownDefinitions defs ) => CompilableProgram (Module defs) where + compile flags (Module program) + = case runCodeGen cgContext (toAST program) of + Left err -> Prelude.pure ( Left err ) + Right ( bytes, cgState ) + -> let + reqs :: ModuleRequirements + reqs = ModuleRequirements + { requiredCapabilities = neededCapabilities ( moduleState cgState ) + , requiredExtensions = neededExtensions ( moduleState cgState ) + } + mbBin :: Maybe ModuleBinary + mbBin + | emittingCode cgContext + = Just (ModuleBinary bytes) + | otherwise + = Nothing + in Prelude.pure ( Right (mbBin, reqs) ) + where cgContext :: CGContext + cgContext = + updateContextFromFlags + ( initialCGContext @defs ) + flags + +instance ( KnownDefinitions defs ) + => CompilableProgram (ShaderModule name stage defs endState) + where + compile flags (ShaderModule prog) + = compile flags (Module @defs prog) + +-- | Utility function to run IO actions at compile-time using Template Haskell. +-- Useful for compiling shaders at compile-time, before launching a graphics application. +-- +-- __Usage example__: in a module which imports this module and shaders +-- @vertexShader@, @fragmentShader@ (bearing in mind the TH staging restriction), write: +-- +-- > shaderCompilationResult :: Either ShortText ModuleRequirements +-- > shaderCompilationResult = +-- > $( runCompilationsTH +-- > [ ("Vertex shader" , compileTo vertPath [] vertexShader ) +-- > , ("Fragment shader", compileTo fragPath [] fragmentShader) +-- > ] +-- > ) +-- +-- At compile-time, this will compile the vertexShader @vertexShader@ at filepath @vertPath@, +-- and similarly for the fragment shader. +-- These can then be loaded into Vulkan shader modules for use in rendering. +runCompilationsTH + :: forall f. Traversable f + => f ( ShortText, IO (Either ShortText ModuleRequirements) ) + -> TH.Q TH.Exp +runCompilationsTH namedCompilations + = TH.lift Prelude.=<< TH.runIO (combineCompilations namedCompilations) + where + combineCompilations + :: f ( ShortText, IO (Either ShortText ModuleRequirements) ) + -> IO (Either ShortText ModuleRequirements) + combineCompilations + = fmap ( foldl' ( \ b (n,a) -> combineResult n b a ) (Right mempty) ) + . traverse ( uncurry rightStrength ) + + combineResult + :: ShortText + -> Either ShortText ModuleRequirements + -> Either ShortText ModuleRequirements + -> Either ShortText ModuleRequirements + combineResult _ (Right rs ) (Right ss) = Right (rs <> ss) + combineResult _ (Left errs) (Right _ ) = Left errs + combineResult name (Right _ ) (Left err) = Left (name <> ": " <> err) + combineResult name (Left errs ) (Left err) = Left (errs <> "\n" <> name <> ": " <> err) diff --git a/src/FIR/AST.hs b/src/FIR/AST.hs new file mode 100644 --- /dev/null +++ b/src/FIR/AST.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -O0 #-} + +{-| +Module: FIR.AST + +Representation of programs using abstract syntax trees. + +The user interface to the AST is through type class overloading, +see "FIR.Syntax.AST" and "FIR.Syntax.Program". + +This is an extensible AST represented by an open sum type (variant type), +with a higher-order abstract syntax representation (HOAS), +as seen in the paper /Combining Deep and Shallow Embeddings of Domain-Specific Languages/ +by Josef Svenningsson and Emil Axelsson. +-} + +module FIR.AST + ( -- * Main AST data type + AST, Code + -- * Syntactic type class + , Syntactic(Internal, toAST, fromAST) + , SyntacticVal, InternalType + -- * Primitive operations + , primOp + , HasUndefined(undefined) + -- * Displaying ASTs graphically + , toTree + + -- * Re-exports + , module FIR.AST.ControlFlow + , module FIR.AST.Effs + , module FIR.AST.Exts + , module FIR.AST.Images + , module FIR.AST.Optics + , module FIR.AST.Prim + + ) + where + +-- base +import Prelude + hiding ( undefined ) +import qualified Prelude +import Data.Typeable +import Data.Kind + ( Type, Constraint ) + +-- tree-view +import Data.Tree.View + ( showTree ) + +-- variant +import Data.Variant.EGADT + ( EGADT ) + +-- fir +import FIR.AST.ControlFlow +import FIR.AST.Display + ( toTree ) +import FIR.AST.Effs +import FIR.AST.Exts +import FIR.AST.Images +import FIR.AST.Optics +import FIR.AST.Prim +import FIR.AST.Type + +import FIR.Prim.Op + ( PrimOp(PrimOpAugType) ) +import {-# SOURCE #-} FIR.Prim.Types + ( PrimTy ) + +------------------------------------------------------------ +-- main AST data type: extensible GADT + +type AllOpsF + = '[ LamF, AppF, LitF, MkIDF, ValueF, UnsafeCoerceF + , IxMonadF + , PrimOpF, UndefinedF, GradedMappendF + , ApplicativeF + , MkVectorF, MatF, StructF, ArrayF, ArrayLengthF, HListF + , SelectionF, LoopF + , LetF, DefF, FunDefF, FunCallF, DefEntryPointF, StateF + , DebugPrintfF, RayF + , ImgOpsF, ImgQueryF + , OpticF + ] + +type AST = EGADT AllOpsF +type Code a = AST (Val a) + +------------------------------------------------ + +-- | Syntactic type class (Axelsson, Svenningsson). +class Syntactic a where + type Internal a :: AugType + toAST :: a -> AST (Internal a) + fromAST :: AST (Internal a) -> a + +type family SyntacticVal a :: Constraint where + SyntacticVal a = ( Syntactic a, Internal a ~ Val (InternalType a) ) +type InternalType a = UnderlyingType (Internal a) + +instance Syntactic (AST a) where + type Internal (AST a) = a + toAST = id + fromAST = id + +instance (SyntacticVal a, Syntactic b) => Syntactic (a -> b) where + type Internal (a -> b) = Internal a :--> Internal b + toAST f = Lam @( Val (InternalType a) :--> Internal b ) + ( toAST . f . fromAST ) + fromAST (Lam f) a = fromAST ( f $ toAST a ) + fromAST f a = fromAST ( f :$ toAST a ) + +------------------------------------------------ + +-- | Utility function for defining primops. +primOp :: forall a op r + . ( PrimOp op a + , Syntactic r + , Internal r ~ PrimOpAugType op a + ) + => r +primOp = fromAST $ PrimOp ( Proxy @a ) ( Proxy @op ) + +-- | Types at which we can define "undefined." +class HasUndefined (a :: Type) where + undefined :: a + +instance PrimTy a => HasUndefined (Code a) where + undefined = Undefined + +instance {-# OVERLAPPABLE #-} HasUndefined a where + undefined = Prelude.undefined + +------------------------------------------------ +-- display AST for viewing + +instance Show (AST ast) where + show = showTree . toTree diff --git a/src/FIR/AST.hs-boot b/src/FIR/AST.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/AST.hs-boot @@ -0,0 +1,60 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module FIR.AST + ( AST, Code + , Syntactic(..) + , InternalType + ) + where + +-- variant +import Data.Variant.EGADT + ( EGADT ) + +-- fir +import FIR.AST.Type + ( AugType(Val), UnderlyingType ) +import {-# SOURCE #-} FIR.AST.ControlFlow + ( SelectionF, LoopF ) +import {-# SOURCE #-} FIR.AST.Effs + ( LetF, DefF, FunDefF, FunCallF, DefEntryPointF, StateF ) +import {-# SOURCE #-} FIR.AST.Exts + ( DebugPrintfF, RayF ) +import {-# SOURCE #-} FIR.AST.Images + ( ImgOpsF, ImgQueryF ) +import {-# SOURCE #-} FIR.AST.Optics + ( OpticF ) +import {-# SOURCE #-} FIR.AST.Prim + ( LamF, AppF, LitF, MkIDF, ValueF, UnsafeCoerceF + , IxMonadF + , PrimOpF, UndefinedF, GradedMappendF + , ApplicativeF + , MkVectorF, MatF, StructF, ArrayF, ArrayLengthF, HListF + ) + +------------------------------------------------------------ + +type AllOpsF + = '[ LamF, AppF, LitF, MkIDF, ValueF, UnsafeCoerceF + , IxMonadF + , PrimOpF, UndefinedF, GradedMappendF + , ApplicativeF + , MkVectorF, MatF, StructF, ArrayF, ArrayLengthF, HListF + , SelectionF, LoopF + , LetF, DefF, FunDefF, FunCallF, DefEntryPointF, StateF + , DebugPrintfF, RayF + , ImgOpsF, ImgQueryF + , OpticF + ] + +type AST = EGADT AllOpsF +type Code a = AST (Val a) + +class Syntactic a where + type Internal a :: AugType + toAST :: a -> AST (Internal a) + fromAST :: AST (Internal a) -> a + +type InternalType a = UnderlyingType (Internal a) diff --git a/src/FIR/AST/ControlFlow.hs b/src/FIR/AST/ControlFlow.hs new file mode 100644 --- /dev/null +++ b/src/FIR/AST/ControlFlow.hs @@ -0,0 +1,157 @@ +{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: FIR.AST.ControlFlow + +AST operations involving control flow (conditional branching, selections, loops). +-} + +module FIR.AST.ControlFlow where + +-- base +import Data.Kind + ( Type ) +import Data.Proxy + ( Proxy(..) ) +import qualified GHC.Stack + ( HasCallStack ) +import GHC.TypeNats + ( KnownNat, natVal ) + +-- containers +import Data.Tree + ( Tree(Node) ) + +-- variant +import Data.Variant.EGADT + ( EGADT, type (:)), Eff ) +import {-# SOURCE #-} FIR.Prim.Types + ( PrimTy, IntegralTy ) +import FIR.Validation.CFG + ( InLoop ) + +------------------------------------------------------------ + +pattern If :: forall a fs + . ( GHC.Stack.HasCallStack, PrimTy a, SelectionF : EGADT fs ( Val Bool :--> Val a :--> Val a :--> Val a ) +pattern If = VF IfF +pattern IfM = VF IfMF +pattern Switch s d cs = VF (SwitchF s d cs) +pattern SwitchM s d cs = VF (SwitchMF s d cs) + +pattern While = VF WhileF +pattern Loop = VF LoopF +pattern Break n = VF (BreakF n) +pattern BreakContinue n = VF (BreakContinueF n) + +data SelectionF ( ast :: AugType -> Type ) ( t :: AugType ) where + -- | If-then-else statement. + IfF + :: ( GHC.Stack.HasCallStack + , PrimTy a + ) + => SelectionF ast ( Val Bool :--> Val a :--> Val a :--> Val a ) + + -- | Monadic if-then-else. + IfMF + :: GHC.Stack.HasCallStack + => SelectionF ast ( Eff i i Bool :--> Eff i j a :--> Eff i k a :--> Eff i i a ) + + -- | Switch statement. + SwitchF + :: ( GHC.Stack.HasCallStack + , PrimTy a + , IntegralTy s + ) + => ast ( Val s ) -- ^ Scrutinee. + -> ast ( Val a ) -- ^ Default case. + -> [ ( s, ast (Val a) ) ] -- ^ Cases. + -> SelectionF ast ( Val a ) + + -- | Monadic switch statement. + SwitchMF + :: ( GHC.Stack.HasCallStack + , PrimTy a + , IntegralTy s + ) + => ast ( Eff i i s ) -- ^ Scrutinee. + -> ast ( Eff i i a ) -- ^ Default case. + -> [ ( s, ast ( Eff i i a ) ) ] -- ^ Cases. + -> SelectionF ast ( Eff i i a ) + -- ( SwitchM could be generalised by allowing different return types in the branches.) + +data LoopF ( ast :: AugType -> Type ) ( t :: AugType ) where + -- | While loop. + WhileF + :: GHC.Stack.HasCallStack + => LoopF ast ( Eff i i Bool :--> Eff (InLoop i) j () :--> Eff i i () ) + + -- | Loop. + LoopF + :: GHC.Stack.HasCallStack + => LoopF ast ( Eff (InLoop i) j () :--> Eff i i () ) + + -- | Break out of the given number of loops. + BreakF + :: ( KnownNat n, GHC.Stack.HasCallStack ) + => Proxy n + -> LoopF ast ( Eff i i () ) + + -- | Break out of the given number of loops, and continue from the resulting loop. + BreakContinueF + :: ( KnownNat n, GHC.Stack.HasCallStack ) + => Proxy n + -> LoopF ast ( Eff i i () ) + +------------------------------------------------------------ +-- displaying + +instance Display ast => Display (SelectionF ast) where + toTreeArgs as IfF = pure ( Node "If" as ) + toTreeArgs as IfMF = pure ( Node "IfM" as ) + toTreeArgs as ( SwitchF s d cs ) = do + scrut <- toTreeArgs [] s + def <- toTreeArgs [] d + cases <- traverse ( secondF ( toTreeArgs [] ) ) cs + let + allCases + = map ( \(v,a) -> Node ("Case " ++ show v) [a] ) cases + ++ [ Node "Default" [def] ] + return (Node "Switch" (scrut : allCases ++ as)) + toTreeArgs as (SwitchMF s d cs) = do + scrut <- toTreeArgs [] s + def <- toTreeArgs [] d + cases <- traverse ( secondF ( toTreeArgs [] ) ) cs + let + allCases + = map ( \(v,a) -> Node ("Case " ++ show v) [a] ) cases + ++ [ Node "Default" [def] ] + return (Node "SwitchM" (scrut : allCases ++ as)) + +instance Display ast => Display (LoopF ast) where + toTreeArgs as WhileF = pure ( Node "While" as ) + toTreeArgs as LoopF = pure ( Node "Loop" as ) + toTreeArgs as ( BreakF n ) = pure ( Node ( "Break @" ++ show ( natVal n ) ) as ) + toTreeArgs as ( BreakContinueF n ) = + let + nm = case natVal n of + 0 -> "Continue" + i -> "BreakContinue @" ++ show i + in pure ( Node nm as ) diff --git a/src/FIR/AST/ControlFlow.hs-boot b/src/FIR/AST/ControlFlow.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/AST/ControlFlow.hs-boot @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} + +module FIR.AST.ControlFlow where + +-- base +import Data.Kind + ( Type ) + +-- fir +import FIR.AST.Type + ( AugType ) + +------------------------------------------------------------ + +data SelectionF ( ast :: AugType -> Type ) ( t :: AugType ) +data LoopF ( ast :: AugType -> Type ) ( t :: AugType ) + +type role SelectionF representational nominal +type role LoopF phantom nominal diff --git a/src/FIR/AST/Display.hs b/src/FIR/AST/Display.hs new file mode 100644 --- /dev/null +++ b/src/FIR/AST/Display.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.AST.Display + +Graphically displaying syntax trees for inspection. + +Each constructor of the AST must provide a `Display` instance. +-} + + +module FIR.AST.Display + ( Display(toTreeArgs), toTree, named ) + where + +-- base +import Data.Kind + ( Type ) + +-- containers +import Data.Tree + ( Tree(Node) ) + +-- mtl +import Control.Monad.State.Lazy + ( evalState ) + +-- variant +import Data.Variant.EGADT + ( EGADT(..), HVariantF(..) ) +import Data.Variant.VariantF + ( VariantF(VariantF), ApplyAll, BottomUp(toBottomUp) ) + +-- fir +import CodeGen.Instruction + ( ID(ID) ) +import CodeGen.Monad + ( MonadFresh, runFreshSuccT ) + +------------------------------------------------------------------------------------- + +class Display (f :: k -> Type) where + toTreeArgs :: MonadFresh ID m => [Tree String] -> f a -> m (Tree String) + +toTree :: Display f => f a -> Tree String +toTree = (`evalState` (ID 1)) . runFreshSuccT . toTreeArgs [] + +instance BottomUp Display fs => Display (VariantF fs) where + toTreeArgs as = toBottomUp @Display ( toTreeArgs as ) + +deriving via VariantF ( ApplyAll (EGADT fs) fs ) + instance BottomUp Display ( ApplyAll (EGADT fs) fs ) + => Display ( EGADT fs ) + +named :: Monad m => ( f a -> String ) -> ( [Tree String] -> f a -> m (Tree String) ) +named name as f = pure ( Node ( name f ) as ) diff --git a/src/FIR/AST/Effs.hs b/src/FIR/AST/Effs.hs new file mode 100644 --- /dev/null +++ b/src/FIR/AST/Effs.hs @@ -0,0 +1,218 @@ +{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: FIR.AST.Effs + +Effectful operations of the AST: + * defining new variables/functions/entry-points, + * management of indexed state. +-} + +module FIR.AST.Effs where + +-- base +import Data.Kind + ( Type ) +import Data.Proxy + ( Proxy ) +import qualified GHC.Stack + ( HasCallStack ) +import GHC.TypeLits + ( Symbol, KnownSymbol, symbolVal ) +import GHC.TypeNats + ( Nat ) + +-- variant +import Data.Variant.EGADT + ( pattern VF ) + +-- fir +import Data.Constraint.All + ( All ) +import Data.Type.Known + ( Known, knownValue ) +import FIR.AST.Display + ( Display(toTreeArgs), named ) +import FIR.AST.Type + ( AugType(Val, (:-->)), Eff, FunArgs, Nullary ) +import FIR.Binding + ( BindingsMap + , FunctionAugType, Var, Permissions + ) +import FIR.Prim.Types + ( PrimTy, KnownVars ) +import FIR.ProgramState + ( ProgramState, TLInterface ) +import FIR.Validation.Bindings + ( ValidDef, ValidFunDef, FunctionTypes + , AddBinding, AddFunBinding + , FunctionDefinitionStartState, FunctionDefinitionEndState + , ValidEntryPoint, SetInterface + , GetExecutionInfo + , EntryPointStartState, EntryPointEndState + , Embeddable + ) +import qualified SPIRV.Stage as SPIRV + ( ExecutionModel, ExecutionInfo ) + +------------------------------------------------------------ + +pattern Let = VF LetF +pattern Def k ps = VF ( DefF k ps ) +pattern FunDef name as b = VF ( FunDefF name as b ) +pattern FunCall name as b = VF ( FunCallF name as b ) +pattern DefEntryPoint name info = VF ( DefEntryPointF name info ) +pattern Locally = VF LocallyF +pattern Embed = VF EmbedF + +-- | Let binding. +data LetF ( ast :: AugType -> Type ) ( t :: AugType ) where + LetF :: GHC.Stack.HasCallStack => LetF ast ( Val a :--> Eff i i a ) + +-- | Defining a new constant/variable. +data DefF ( ast :: AugType -> Type ) ( t :: AugType ) where + DefF + :: forall + ( k :: Symbol ) + ( ps :: Permissions ) + ( a :: Type ) + ( i :: ProgramState ) + ( ast :: AugType -> Type ) + . ( GHC.Stack.HasCallStack + , KnownSymbol k + , Known Permissions ps + , PrimTy a + , ValidDef k i a + ) + => Proxy k -- ^ Variable name. + -> Proxy ps -- ^ Permissions (read,write,...). + -> DefF ast ( Val a :--> Eff i (AddBinding k (Var ps a) i) a ) + +-- | Defining a new function. +-- +-- Meaning of type variables: +-- * name: function name, +-- * as: named function arguments (usually inferred), +-- * b: function return type (usually inferred), +-- * j_bds: bindings state at end of function definition (usually inferred), +-- * i: monadic state at function definition site (usually inferred). +data FunDefF ( ast :: AugType -> Type ) ( t :: AugType ) where + FunDefF + :: forall + ( name :: Symbol ) + ( as :: BindingsMap ) + ( b :: Type ) + ( j_bds :: BindingsMap ) + ( i :: ProgramState ) + ( ast :: AugType -> Type ) + . ( GHC.Stack.HasCallStack + , KnownSymbol name + , KnownVars as + , PrimTy b + , ValidFunDef name as i j_bds + , '(as,b) ~ FunctionTypes name i + ) + => Proxy name -- ^ Funtion name. + -> Proxy as -- ^ Function argument types. + -> Proxy b -- ^ Function return type. + -> FunDefF ast + ( Eff + ( FunctionDefinitionStartState name as i ) + ( FunctionDefinitionEndState name as j_bds i ) + b + :--> Eff i ( AddFunBinding name as b i ) ( FunctionHandle name as b ) + ) + +data FunctionHandle (name :: Symbol) (as :: BindingsMap) (b :: Type) + +data FunCallF ( ast :: AugType -> Type ) ( t :: AugType ) where + FunCallF + :: ( KnownSymbol name + , KnownVars as + , PrimTy b + , All Nullary (FunArgs (FunctionAugType as b)) + ) + => Proxy name + -> Proxy as + -> Proxy b + -> FunCallF ast ( Val (FunctionHandle name as b) :--> FunctionAugType as b ) + +-- | Defining a new entry point. +-- +-- An entry point is like a function definition with no arguments and Unit return type. +-- Code within an entry point is given access to additional builtins. +-- +-- Meaning of type variables: +-- * name: entry point name, +-- * stage: entry point stage, +-- * stageInfo: entry point stage info (usually inferred), +-- * j_bds: bindings state at end of entry point definition (usually inferred), +-- * j_iface: entry point interface (usually inferred), +-- * i: monadic state at entry point definition site (usually inferred). +data DefEntryPointF ( ast :: AugType -> Type ) ( t :: AugType ) where + DefEntryPointF + :: forall + ( name :: Symbol ) + ( stage :: SPIRV.ExecutionModel ) + ( stageInfo :: SPIRV.ExecutionInfo Nat stage ) + ( j_bds :: BindingsMap ) + ( j_iface :: TLInterface ) + ( i :: ProgramState ) + ( ast :: AugType -> Type ) + . ( GHC.Stack.HasCallStack + , KnownSymbol name + , Known SPIRV.ExecutionModel stage + , Known (SPIRV.ExecutionInfo Nat stage) stageInfo + , ValidEntryPoint name stageInfo i j_bds + , stageInfo ~ GetExecutionInfo name stage i + ) + => Proxy name -- ^ Entry point name. + -> Proxy stageInfo -- ^ Entry point stage info. + -> DefEntryPointF ast + ( Eff + ( EntryPointStartState name stageInfo i ) + ( EntryPointEndState name stageInfo j_bds j_iface i ) + () + :--> ( Eff i ( SetInterface name stageInfo j_iface i ) () ) + ) + + +data StateF ( ast :: AugType -> Type ) ( t :: AugType ) where + -- | Encapsulate local state. + LocallyF :: StateF ast ( Eff i j a :--> Eff i i a ) + + -- | Embed a computation into one with larger state. + EmbedF :: Embeddable i j => StateF ast ( Eff i i a :--> Eff j j a ) + +------------------------------------------------------------ +-- displaying + +instance Display (LetF ast) where + toTreeArgs = named \ LetF -> "Let" +instance Display (DefF ast) where + toTreeArgs = named \(DefF k _) -> + "Def @" ++ symbolVal k +instance Display (FunDefF ast) where + toTreeArgs = named \(FunDefF k _ _) -> + "FunDef @" ++ symbolVal k +instance Display (FunCallF ast) where + toTreeArgs = named \(FunCallF k _ _) -> + "FunCall @" ++ symbolVal k +instance Display (DefEntryPointF ast) where + toTreeArgs = named \(DefEntryPointF _ (_ :: Proxy (stageInfo :: SPIRV.ExecutionInfo Nat stage) )) -> + "Entry @(" ++ show (knownValue @stage) ++ ")" +instance Display (StateF ast) where + toTreeArgs = named \ case + LocallyF -> "Locally" + EmbedF -> "Embed" diff --git a/src/FIR/AST/Effs.hs-boot b/src/FIR/AST/Effs.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/AST/Effs.hs-boot @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} + +module FIR.AST.Effs where + +-- base +import Data.Kind + ( Type ) + +-- fir +import FIR.AST.Type + ( AugType ) + +------------------------------------------------------------ + +data LetF ( ast :: AugType -> Type ) ( t :: AugType ) +data DefF ( ast :: AugType -> Type ) ( t :: AugType ) +data FunDefF ( ast :: AugType -> Type ) ( t :: AugType ) +data FunCallF ( ast :: AugType -> Type ) ( t :: AugType ) +data DefEntryPointF ( ast :: AugType -> Type ) ( t :: AugType ) +data StateF ( ast :: AugType -> Type ) ( t :: AugType ) + +type role LetF phantom nominal +type role DefF phantom nominal +type role FunDefF phantom nominal +type role FunCallF phantom nominal +type role DefEntryPointF phantom nominal +type role StateF phantom nominal diff --git a/src/FIR/AST/Exts.hs b/src/FIR/AST/Exts.hs new file mode 100644 --- /dev/null +++ b/src/FIR/AST/Exts.hs @@ -0,0 +1,261 @@ +{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.AST.Exts + +Additional operations, such as ray tracing operations and Debug Printf. +-} + +module FIR.AST.Exts where + +-- base +import Data.Kind + ( Type ) +import Data.Proxy + ( Proxy ) +import Data.Word + ( Word32 ) + +-- containers +import Data.Tree + ( Tree(Node) ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( unpack ) + +-- variant +import Data.Variant.EGADT + ( pattern VF ) + +-- fir +import Data.Constraint.All + ( All ) +import FIR.AST.Display + ( Display(toTreeArgs), named ) +import FIR.AST.Type + ( AugType(..), Eff + , Nullary, FunArgs, FunRes + ) +import FIR.Prim.RayTracing + ( AccelerationStructure + , RayQuery(..), IntersectionType(..) + ) +import FIR.Prim.Types + ( PrimTy ) +import FIR.ProgramState + ( ProgramState ) +import Math.Linear + ( V ) +import qualified SPIRV.Operation as SPIRV + ( Operation, showOperation ) + +------------------------------------------------------------ + +pattern DebugPrintf formatString = VF ( DebugPrintfF formatString ) +pattern + TraceRay + { traceRayAccelerationStructure + , traceRayRayFlags + , traceRayCullMask + , traceRaySBTOffset + , traceRaySBTStride + , traceRayMissIndex + , traceRayRayOrigin + , traceRayRayTMin + , traceRayRayDirection + , traceRayRayTMax + , traceRayPayloadID + } = VF + ( TraceRayF + traceRayAccelerationStructure + traceRayRayFlags + traceRayCullMask + traceRaySBTOffset + traceRaySBTStride + traceRayMissIndex + traceRayRayOrigin + traceRayRayTMin + traceRayRayDirection + traceRayRayTMax + traceRayPayloadID + ) +pattern ExecuteCallable sbtIndex dataID = VF ( ExecuteCallableF sbtIndex dataID ) +pattern + RayQueryInitialize + { rayQueryRayQueryName + , rayQueryAccelerationStructure + , rayQueryRayFlags + , rayQueryCullMask + , rayQueryRayOrigin + , rayQueryRayTMin + , rayQueryRayDirection + , rayQueryRayTMax + } = VF + ( RayQueryInitializeF + rayQueryRayQueryName + rayQueryAccelerationStructure + rayQueryRayFlags + rayQueryCullMask + rayQueryRayOrigin + rayQueryRayTMin + rayQueryRayDirection + rayQueryRayTMax + ) +pattern RayQueryPrimOp px rayQueryOp rayQueryName mbIntersectionType = + VF ( RayQueryPrimOpF px rayQueryOp rayQueryName mbIntersectionType ) + + +-- | Printf debugging statement (SPIR-V non-semantic extension). +data DebugPrintfF ( ast :: AugType -> Type ) ( t :: AugType ) where + DebugPrintfF + :: All Nullary ( FunArgs ( PrintfAugType i as ) ) + => ShortText -- ^ PrintF format string + -> DebugPrintfF ast ( PrintfAugType i as ) + +type family PrintfAugType ( i :: ProgramState ) ( as :: [ Type ] ) = ( r :: AugType ) | r -> as i where + PrintfAugType i '[] = Eff i i () + PrintfAugType i ( a ': as ) = Val a :--> PrintfAugType i as + + +data RayF ( ast :: AugType -> Type ) ( t :: AugType ) where + -- | Trace a ray into the given acceleration structure. + TraceRayF :: + { traceRayFAccelerationStructure :: ast ( Val AccelerationStructure ) + , traceRayFRayFlags :: ast ( Val Word32 ) + , traceRayFCullMask :: ast ( Val Word32 ) + , traceRayFSBTOffset :: ast ( Val Word32 ) + , traceRayFSBTStride :: ast ( Val Word32 ) + , traceRayFMissIndex :: ast ( Val Word32 ) + , traceRayFRayOrigin :: ast ( Val ( V 3 Float ) ) + , traceRayFRayTMin :: ast ( Val Float ) + , traceRayFRayDirection :: ast ( Val ( V 3 Float ) ) + , traceRayFRayTMax :: ast ( Val Float ) + , traceRayFRayPayloadName :: ShortText + } -> RayF ast ( Eff i i () ) + + -- | Invoke a callable shader. + ExecuteCallableF :: + { executeCallableFSBTIndex :: ast ( Val Word32 ) + , executeCallableFDataName :: ShortText + } -> RayF ast ( Eff i i () ) + + -- | Initialise a ray query. + RayQueryInitializeF :: + { rayQueryFRayQueryName :: RayQuery + , rayQueryFAccelerationStructure :: ast ( Val AccelerationStructure ) + , rayQueryFRayFlags :: ast ( Val Word32 ) + , rayQueryFCullMask :: ast ( Val Word32 ) + , rayQueryFRayOrigin :: ast ( Val ( V 3 Float ) ) + , rayQueryFRayTMin :: ast ( Val Float ) + , rayQueryFRayDirection :: ast ( Val ( V 3 Float ) ) + , rayQueryFRayTMax :: ast ( Val Float ) + } -> RayF ast ( Eff i j () ) + + -- | Ray query operations. + RayQueryPrimOpF + :: ( All Nullary ( FunArgs opTy ) + , FunRes opTy ~ Eff i i a + , PrimTy a + ) + => Proxy a + -> SPIRV.Operation + -> RayQuery + -> Maybe IntersectionType + -> RayF ast opTy + +------------------------------------------------------------ +-- displaying + +instance Display ast => Display (DebugPrintfF ast) where + toTreeArgs = named \(DebugPrintfF formatString) -> + "DebugPrintf \"" <> ShortText.unpack formatString <> "\"" + +instance Display ast => Display (RayF ast) where + + toTreeArgs as (TraceRayF {..}) = do + accelerationStructure <- toTreeArgs [] traceRayFAccelerationStructure + rayFlags <- toTreeArgs [] traceRayFRayFlags + cullMask <- toTreeArgs [] traceRayFCullMask + sbtOffset <- toTreeArgs [] traceRayFSBTOffset + sbtStride <- toTreeArgs [] traceRayFSBTStride + missIndex <- toTreeArgs [] traceRayFMissIndex + rayOrigin <- toTreeArgs [] traceRayFRayOrigin + rayTMin <- toTreeArgs [] traceRayFRayTMin + rayDirection <- toTreeArgs [] traceRayFRayDirection + rayTMax <- toTreeArgs [] traceRayFRayTMax + let + rayPayloadName = ShortText.unpack traceRayFRayPayloadName + pure $ + Node "TraceRay" + ( accelerationStructure + : rayFlags + : cullMask + : sbtOffset + : sbtStride + : missIndex + : rayOrigin + : rayTMin + : rayDirection + : rayTMax + : Node rayPayloadName [] + : as + ) + + toTreeArgs as (ExecuteCallableF {..}) = do + sbtIndex <- toTreeArgs [] executeCallableFSBTIndex + let + callableDataName = ShortText.unpack executeCallableFDataName + pure $ + Node "ExecuteCallable" + ( sbtIndex + : Node callableDataName [] + : as + ) + + toTreeArgs as (RayQueryInitializeF {..}) = do + let + RayQuery rayQueryName = rayQueryFRayQueryName + accelerationStructure <- toTreeArgs [] rayQueryFAccelerationStructure + rayFlags <- toTreeArgs [] rayQueryFRayFlags + cullMask <- toTreeArgs [] rayQueryFCullMask + rayOrigin <- toTreeArgs [] rayQueryFRayOrigin + rayTMin <- toTreeArgs [] rayQueryFRayTMin + rayDirection <- toTreeArgs [] rayQueryFRayDirection + rayTMax <- toTreeArgs [] rayQueryFRayTMax + pure $ + Node "RayQueryInitialize" + ( Node ( ShortText.unpack rayQueryName ) [] + : accelerationStructure + : rayFlags + : cullMask + : rayOrigin + : rayTMin + : rayDirection + : rayTMax + : as + ) + + toTreeArgs as (RayQueryPrimOpF _ rayQueryOp (RayQuery rayQueryName) mbInterType) = + pure $ + Node ( SPIRV.showOperation rayQueryOp ) + ( Node ( ShortText.unpack rayQueryName ) [] + : ( case mbInterType of + Nothing -> id + Just Candidate -> ( Node "Candidate" [] : ) + Just Committed -> ( Node "Committed" [] : ) + ) as + ) diff --git a/src/FIR/AST/Exts.hs-boot b/src/FIR/AST/Exts.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/AST/Exts.hs-boot @@ -0,0 +1,22 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} + +module FIR.AST.Exts where + +-- base +import Data.Kind + ( Type ) + +-- fir +import FIR.AST.Type + ( AugType ) + +------------------------------------------------------------ + +data DebugPrintfF ( ast :: AugType -> Type ) ( t :: AugType ) +data RayF ( ast :: AugType -> Type ) ( t :: AugType ) + + +type role DebugPrintfF phantom nominal +type role RayF representational nominal diff --git a/src/FIR/AST/Images.hs b/src/FIR/AST/Images.hs new file mode 100644 --- /dev/null +++ b/src/FIR/AST/Images.hs @@ -0,0 +1,291 @@ +{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: FIR.AST.Images + +Handling image operands and image query operations. +-} + +module FIR.AST.Images where + +-- base +import Data.Kind + ( Type ) +import Data.Proxy + ( Proxy ) +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( KnownSymbol, symbolVal ) + +-- containers +import Data.Tree + ( Tree(Node) ) + +-- variant +import Data.Variant.EGADT + ( pattern VF ) + +-- fir +import FIR.AST.Display + ( Display(toTreeArgs), named ) +import FIR.AST.Type + ( AugType(..), Eff ) +import {-# SOURCE #-} FIR.Prim.Image + ( ImageOperands, OperandName(..) + , GatherInfo(..), WhichGather + ) +import {-# SOURCE #-} FIR.Prim.Types + ( PrimTy ) +import FIR.Validation.Images + ( BasicDim, NotCubeDim + , CanAddProj, CanAddDref + , UsesAffineCoords + , NoDuplicate + , NoMS, CanMultiSample + , NoLODOps + , ValidImageCoordinate, ValidImageGradCoordinate, ValidImageOffsetCoordinate + ) +import qualified SPIRV.Image as SPIRV + +------------------------------------------------------------ + +infixl 5 `Dref` +infixl 5 `Bias` +infixl 5 `LOD` +infixl 5 `MinLOD` +infixl 5 `Grad` +infixl 5 `ConstOffsetBy` +infixl 5 `OffsetBy` +infixl 5 `Gather` +infixl 5 `SampleNo` + +pattern NilOps = VF NilOpsF +pattern Proj ops = VF (ProjF ops) +pattern Dref ref ops = VF (DrefF ref ops) +pattern Bias bias ops = VF (BiasF bias ops) +pattern LOD lod ops = VF (LODF lod ops) +pattern MinLOD lod ops = VF (MinLODF lod ops) +pattern Grad grad ops = VF (GradF grad ops) +pattern ConstOffsetBy off ops = VF (ConstOffsetByF off ops) +pattern OffsetBy off ops = VF (OffsetByF off ops) +pattern Gather gath ops = VF (GatherF gath ops) +pattern SampleNo sno ops = VF (SampleNoF sno ops) + +pattern QuerySize img res = VF ( QuerySizeF img res ) +pattern QuerySizeLOD img res = VF ( QuerySizeLODF img res ) +pattern QueryLOD img res = VF ( QueryLODF img res ) +pattern QueryLevels img res = VF ( QueryLevelsF img res ) +pattern QuerySamples img res = VF ( QuerySamplesF img res ) + +data ImgOpsF ( ast :: AugType -> Type ) ( t :: AugType ) where + + -- | End of (snoc-)list of image operands. + NilOpsF :: ImgOpsF ast ( Val ( ImageOperands props '[] ) ) + + -- | Use projective coordinates. + -- + -- Must be provided after all other operands, + -- except possibly 'Dref'. + ProjF + :: CanAddProj ops + => ast ( Val ( ImageOperands props ops ) ) + -> ImgOpsF ast ( Val ( ImageOperands props (ProjectiveCoords ': ops) ) ) + + -- | Provide a depth-comparison reference value. + -- + -- Must be provided after all other operands, + -- except possibly 'Proj'. + DrefF + :: CanAddDref ops + => ast ( Val Float ) -- ^ Reference value used to perform the depth comparison. + -> ast ( Val ( ImageOperands props ops ) ) + -> ImgOpsF ast ( Val ( ImageOperands props (DepthComparison ': ops) ) ) + + -- | Add a bias to the implicit level of detail. + BiasF + :: ( BasicDim "Bias" props + , NoMS "Bias" props + , NoDuplicate (BaseOperand ('SPIRV.LODOperand SPIRV.Bias)) ops + , NoLODOps "Bias" '[SPIRV.LOD, SPIRV.Grad] ops + , ValidImageCoordinate props ops imgCoord + ) + => ast ( Val imgCoord ) -- ^ Bias. + -> ast ( Val ( ImageOperands props ops ) ) + -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand ('SPIRV.LODOperand SPIRV.Bias) ': ops) ) ) + + -- | Provide an explicit level of detail. + LODF + :: ( BasicDim "LOD" props + , NoMS "LOD" props + , NoDuplicate (BaseOperand ('SPIRV.LODOperand SPIRV.LOD)) ops + , NoLODOps "LOD" '[SPIRV.Bias, SPIRV.Grad, SPIRV.MinLOD] ops + , ValidImageCoordinate props ops imgCoord + ) + => ast ( Val imgCoord ) -- ^ LOD. + -> ast ( Val ( ImageOperands props ops ) ) + -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand ('SPIRV.LODOperand SPIRV.LOD ) ': ops) ) ) + + -- | Specify the minimum level of detail to use + -- when sampling the image. + MinLODF + :: ( BasicDim "MinLOD" props + , NoMS "MinLOD" props + , NoDuplicate (BaseOperand ('SPIRV.LODOperand SPIRV.MinLOD)) ops + , NoLODOps "MinLOD" '[SPIRV.LOD, SPIRV.Bias] ops + , ValidImageCoordinate props ops imgCoord + ) + => ast ( Val imgCoord ) -- ^ Minimum LOD. + -> ast ( Val ( ImageOperands props ops ) ) + -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand ('SPIRV.LODOperand SPIRV.MinLOD ) ': ops) ) ) + + -- | Provide explicit derivatives. + GradF + :: ( PrimTy gradCoords + , NoMS "Grad" props + , NoDuplicate (BaseOperand ('SPIRV.LODOperand SPIRV.Grad)) ops + , NoLODOps "Grad" '[ SPIRV.Bias, SPIRV.LOD ] ops + , ValidImageGradCoordinate props ops gradCoords + ) + => ( ast (Val gradCoords), ast (Val gradCoords) ) -- ^ Gradient: ( df\/dx, df\/dy ). + -> ast ( Val ( ImageOperands props ops ) ) + -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand ('SPIRV.LODOperand SPIRV.Grad) ': ops) ) ) + + -- | Add a constant offset to the coordinates. + ConstOffsetByF + :: ( PrimTy offCoords + , NoDuplicate (BaseOperand SPIRV.ConstOffset) ops + , NotCubeDim "ConstOffsetBy" props + , ValidImageOffsetCoordinate props ops offCoords + ) + => offCoords -- Offset (a Haskell constant). + -> ast ( Val ( ImageOperands props ops ) ) + -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand SPIRV.ConstOffset ': ops) ) ) + + -- | Add an offset to the coordinates. + OffsetByF + :: ( PrimTy offCoords + , NoDuplicate (BaseOperand SPIRV.Offset) ops + , NotCubeDim "OffsetBy" props + , ValidImageOffsetCoordinate props ops offCoords + ) + => ast ( Val offCoords ) -- Offset. + -> ast ( Val ( ImageOperands props ops ) ) + -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand SPIRV.Offset ': ops) ) ) + + -- | Specify an image gather operation: gather texel data from 4 specified texel coordinates. + GatherF + :: ( NotCubeDim "Gather" props + , NoDuplicate (BaseOperand SPIRV.ConstOffsets) ops + , NoLODOps "Gather" '[ SPIRV.LOD, SPIRV.Grad, SPIRV.Bias, SPIRV.MinLOD ] ops + , UsesAffineCoords ops + ) + => GatherInfo ( ast ( Val Word32 ) ) (WhichGather ops) + -> ast ( Val ( ImageOperands props ops ) ) + -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand SPIRV.ConstOffsets ': ops) ) ) + + -- | Specify which sample number to use in a multi-sampled image. + SampleNoF + :: ( CanMultiSample props + , NoDuplicate (BaseOperand SPIRV.Sample) ops + ) + => ast ( Val Word32 ) -- ^ Sample number. + -> ast ( Val ( ImageOperands props ops ) ) + -> ImgOpsF ast ( Val ( ImageOperands props (BaseOperand SPIRV.Sample ': ops) ) ) + + +data ImgQueryF ( ast :: AugType -> Type ) ( t :: AugType ) where + -- | Query the size of an image with implicit LOD. + QuerySizeF + :: ( KnownSymbol imgName, PrimTy res ) + => Proxy imgName + -> Proxy res + -> ImgQueryF ast ( Eff i i res ) + -- | Query the size of an image with explicit LOD. + QuerySizeLODF + :: ( KnownSymbol imgName, PrimTy res ) + => Proxy imgName + -> Proxy res + -> ImgQueryF ast ( Val Word32 :--> Eff i i res ) + -- | Query the LOD of an image at given coordinates. + QueryLODF + :: ( KnownSymbol imgName, PrimTy res ) + => Proxy imgName + -> Proxy res + -> ImgQueryF ast ( Val coords :--> Eff i i res ) + -- | Query the number of levels of detail supported by an image. + QueryLevelsF + :: ( KnownSymbol imgName, PrimTy res ) + => Proxy imgName + -> Proxy res + -> ImgQueryF ast ( Eff i i res ) + -- | Query the number of samples of a multi-sampled image. + QuerySamplesF + :: ( KnownSymbol imgName, PrimTy res ) + => Proxy imgName + -> Proxy res + -> ImgQueryF ast ( Eff i i res ) + +------------------------------------------------------------ +-- displaying + +instance Display ast => Display (ImgOpsF ast) where + toTreeArgs as NilOpsF = pure $ Node "NilOps" as + toTreeArgs as (ProjF ops) = do + a <- toTreeArgs [] ops + pure $ Node "Proj" (a:as) + toTreeArgs as (DrefF ref ops) = do + r <- toTreeArgs [] ref + a <- toTreeArgs [] ops + pure $ Node "Dref" (r:a:as) + toTreeArgs as (BiasF bias ops) = do + b <- toTreeArgs [] bias + a <- toTreeArgs [] ops + pure $ Node "Bias=" (b:a:as) + toTreeArgs as (LODF lod ops) = do + l <- toTreeArgs [] lod + a <- toTreeArgs [] ops + pure $ Node "LOD" (l:a:as) + toTreeArgs as (MinLODF lod ops) = do + l <- toTreeArgs [] lod + a <- toTreeArgs [] ops + pure $ Node "MinLOD" (l:a:as) + toTreeArgs as (GradF (dfdx, dfdy) ops) = do + x <- toTreeArgs [] dfdx + y <- toTreeArgs [] dfdy + a <- toTreeArgs [] ops + pure $ Node "Grad" (x:y:a:as) + toTreeArgs as (ConstOffsetByF vec ops) = do + a <- toTreeArgs [] ops + pure $ Node "ConstOffsetBy" (pure (show vec):a:as) + toTreeArgs as (OffsetByF vec ops) = do + v <- toTreeArgs [] vec + a <- toTreeArgs [] ops + pure $ Node "OffsetBy" (v:a:as) + toTreeArgs as (GatherF (ComponentWithOffsets comp offs) ops) = do + c <- toTreeArgs [] comp + a <- toTreeArgs [] ops + pure $ Node "GatherComponentWithOffsets" (c:pure (show offs):a:as) + toTreeArgs as (GatherF (DepthWithOffsets offs) ops) = do + a <- toTreeArgs [] ops + pure $ Node "GatherDepthWithOffsets" (pure (show offs):a:as) + toTreeArgs as (SampleNoF no ops) = do + n <- toTreeArgs [] no + a <- toTreeArgs [] ops + pure $ Node "SampleNo" (n:a:as) + +instance Display ast => Display (ImgQueryF ast) where + toTreeArgs = named \case + QuerySizeF imgName _ -> "ImageQuerySize @" ++ symbolVal imgName + QuerySizeLODF imgName _ -> "ImageQuerySizeLod @" ++ symbolVal imgName + QueryLODF imgName _ -> "ImageQueryLod @" ++ symbolVal imgName + QueryLevelsF imgName _ -> "ImageQueryLevels @" ++ symbolVal imgName + QuerySamplesF imgName _ -> "ImageQuerySamples @" ++ symbolVal imgName diff --git a/src/FIR/AST/Images.hs-boot b/src/FIR/AST/Images.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/AST/Images.hs-boot @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} + +module FIR.AST.Images where + +-- base +import Data.Kind + ( Type ) + +-- fir +import FIR.AST.Type + ( AugType ) + +------------------------------------------------------------ + +data ImgOpsF ( ast :: AugType -> Type ) ( t :: AugType ) +data ImgQueryF ( ast :: AugType -> Type ) ( t :: AugType ) + +type role ImgOpsF representational nominal +type role ImgQueryF phantom nominal diff --git a/src/FIR/AST/Optics.hs b/src/FIR/AST/Optics.hs new file mode 100644 --- /dev/null +++ b/src/FIR/AST/Optics.hs @@ -0,0 +1,170 @@ +{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.AST.Optics + +AST operations involving optics (view, set, use, assign). +-} + +module FIR.AST.Optics where + +-- base +import Data.Kind + ( Type ) +import qualified GHC.Stack + ( HasCallStack ) + +-- variant +import Data.Variant.EGADT + ( pattern VF ) + +-- fir +import {-# SOURCE #-} Control.Type.Optic + ( Optic + , Gettable, ReifiedGetter + , Settable, ReifiedSetter + , Indices, Part + ) +import Data.Type.List + ( SLength, Snoc ) +import FIR.AST.Display + ( Display(toTreeArgs), named ) +import FIR.AST.Type + ( AugType(Val, (:-->)), Eff ) +import FIR.Prim.Atomic + ( SAtomicOp, atomicOp + , AtomicShape(..), AtomicOpShape, AtomicOpTy + ) +import FIR.ProgramState + ( ProgramState ) +import {-# SOURCE #-} FIR.Syntax.Optics + ( KnownOptic, SOptic, showSOptic ) + +------------------------------------------------------------ + +pattern Use lg optic = VF ( UseF lg optic ) +pattern Assign lg optic = VF ( AssignF lg optic ) +pattern View lg optic = VF ( ViewF lg optic ) +pattern Set lg optic = VF ( SetF lg optic ) +pattern Atomic op lg optic = VF ( AtomicF op lg optic ) + + +data OpticF ( ast :: AugType -> Type ) ( t :: AugType ) where + -- | /Use/ an optic, returning a monadic value read from the (indexed) state. + -- + -- Like @use@ from the lens library. + UseF + :: forall optic ast + . ( GHC.Stack.HasCallStack + , KnownOptic optic, Gettable optic + ) + => SLength ( Indices optic ) -- ^ Singleton for the number of run-time indices. + -> SOptic optic -- ^ Singleton for the optic. + -> OpticF ast ( AugUser optic ) + + -- | /Assign/ a new value with an optic. + -- + -- Like @assign@ from the lens library. + AssignF + :: forall optic ast + . ( GHC.Stack.HasCallStack + , KnownOptic optic, Settable optic + ) + => SLength ( Indices optic ) -- ^ Singleton for the number of run-time indices. + -> SOptic optic -- ^ Singleton for the optic. + -> OpticF ast ( AugAssigner optic ) + + -- | /View/: access a value using an optic. + -- + -- Like @view@ from the lens library. + ViewF + :: forall optic ast + . ( GHC.Stack.HasCallStack + , KnownOptic optic, ReifiedGetter optic + ) + => SLength ( Indices optic ) -- ^ Singleton for the number of run-time indices. + -> SOptic optic -- ^ Singleton for the optic. + -> OpticF ast ( AugViewer optic ) + + -- | /Set/: set a value using an optic. + -- + -- Like @set@ from the lens library. + SetF + :: forall optic ast + . ( GHC.Stack.HasCallStack + , KnownOptic optic, ReifiedSetter optic + ) + => SLength ( Indices optic ) -- ^ Singleton for the number of run-time indices. + -> SOptic optic -- ^ Singleton for the optic. + -> OpticF ast ( AugSetter optic ) + + -- | An atomic operation on the scalar an optic focuses on. + AtomicF + :: forall op optic ast + . ( GHC.Stack.HasCallStack + , KnownOptic optic, Gettable optic, Settable optic + , AtomicOpTy op ( Part optic ) + ) + => SAtomicOp op + -> SLength ( Indices optic ) -- ^ Singleton for the number of run-time indices. + -> SOptic optic -- ^ Singleton for the optic. + -> OpticF ast ( AugAtomic ( AtomicOpShape op ) optic ) + +------------------------------------------------------------ +-- type synonyms for augmented types of optical operations + +type AugUser (g :: Optic as i b) = AugListVariadicIx i as b +type AugViewer (g :: Optic is s a) = AugListVariadic (is `Snoc` s) a +type AugAssigner (g :: Optic as i b) = AugListVariadicIx i (as `Snoc` b) () +type AugSetter (g :: Optic is s a) = AugListVariadic (is `Snoc` a `Snoc` s) s +type AugExchanger (g :: Optic as i b) + = AugListVariadicIx i (as `Snoc` b) b +type AugCompareExchanger (g :: Optic as i b) + = AugListVariadicIx i (as `Snoc` b `Snoc` b) b + +-- | The augmented type of an atomic operation of the given shape. +type family AugAtomic (sh :: AtomicShape) (g :: Optic as i b) :: AugType where + AugAtomic 'Reads g = AugUser g + AugAtomic 'Writes g = AugAssigner g + AugAtomic 'Modifies g = AugExchanger g + AugAtomic 'Compares g = AugCompareExchanger g + +type family AugListVariadic + ( as :: [Type] ) + ( b :: Type ) + = ( r :: AugType ) + | r -> as b where + AugListVariadic '[] b = Val b + AugListVariadic (a ': as) b = Val a :--> AugListVariadic as b + +type family AugListVariadicIx + ( i :: ProgramState ) + ( as :: [Type] ) + ( b :: Type ) + = ( r :: AugType ) + | r -> as i b where + AugListVariadicIx i '[] b = Eff i i b + AugListVariadicIx i (a ': as) b = Val a :--> AugListVariadicIx i as b + +------------------------------------------------------------ +-- displaying + +instance Display (OpticF ast) where + toTreeArgs = named \ case + UseF _ o -> "Use @(" ++ showSOptic o ++ ")" + AssignF _ o -> "Assign @(" ++ showSOptic o ++ ")" + ViewF _ o -> "View @(" ++ showSOptic o ++ ")" + SetF _ o -> "Set @(" ++ showSOptic o ++ ")" + AtomicF op _ o -> show ( atomicOp op ) ++ " @(" ++ showSOptic o ++ ")" diff --git a/src/FIR/AST/Optics.hs-boot b/src/FIR/AST/Optics.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/AST/Optics.hs-boot @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} + +module FIR.AST.Optics where + +-- base +import Data.Kind + ( Type ) + +-- fir +import FIR.AST.Type + ( AugType ) + +------------------------------------------------------------ + +data OpticF ( ast :: AugType -> Type ) ( t :: AugType ) + +type role OpticF phantom nominal diff --git a/src/FIR/AST/Prim.hs b/src/FIR/AST/Prim.hs new file mode 100644 --- /dev/null +++ b/src/FIR/AST/Prim.hs @@ -0,0 +1,362 @@ +{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.AST.Prim + +Primitive operations of the AST: + * lambda abstraction, + * function application, + * constant literals; + * primitive SPIR-V operations, + * vector/array/matrix creation, + * ... +-} + +module FIR.AST.Prim where + +-- base +import Data.Foldable + ( toList ) +import Data.Kind + ( Type ) +import GHC.TypeLits + ( Symbol ) +import Data.Proxy + ( Proxy ) +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( KnownSymbol, symbolVal ) +import GHC.TypeNats + ( KnownNat, natVal ) +import Numeric.Natural + ( Natural ) +import Data.Type.Map + +-- containers +import Data.Tree + ( Tree(Node) ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- variant +import Data.Variant.EGADT + ( EGADT, pattern VF, (:)), Eff + , FunArgs, FunRes + , ApplyFAug + ) +import FIR.Prim.Array + ( Array(MkArray) ) +import FIR.Prim.Op + ( PrimOp(PrimOpAugType, opName) + , PrimTyVal + ) +import {-# SOURCE #-} FIR.Prim.Struct + ( Struct, ASTStructFields, traverseStructASTs ) +import {-# SOURCE #-} FIR.Prim.Types + ( PrimTy, primTy + , PrimTyMap, primTyMap + , PrimFunc, primFuncName + ) +import Math.Algebra.GradedSemigroup + ( GradedSemigroup(Grade, (::)) ) +import Math.Linear + ( V, M ) +import qualified SPIRV.PrimOp as SPIRV + ( op ) +import qualified SPIRV.PrimTy as SPIRV + ( PrimTy ) +import qualified SPIRV.Stage as SPIRV + ( Backend(Vulkan) ) + +------------------------------------------------------------ + +infixl 9 :$ +infixr 5 `ConsHList` + +pattern Lam :: forall fun fs + . ( LamF : forall a b + . ( fun ~ ( Val a :--> b ) ) + => ( EGADT fs ( Val a ) -> EGADT fs b ) + -> EGADT fs fun +pattern Lam f = VF (LamF f ) +pattern (:$) f a = VF (AppF f a) +pattern Lit l = VF (LitF l ) +pattern MkID i = VF (MkIDF i ) +pattern Value v = VF (ValueF v ) +pattern UnsafeCoerce = VF UnsafeCoerceF +pattern Return = VF ReturnF +pattern Bind = VF BindF +pattern PrimOp a op = VF (PrimOpF a op) + +pattern Undefined :: forall a fs + . ( PrimTy a, UndefinedF : EGADT fs (Val a) +pattern Undefined = VF UndefinedF +pattern GradedMappend = VF GradedMappendF +pattern Pure px a = VF (PureF px a) +pattern Ap px f a = VF (ApF px f a) +pattern MkVector v = VF (MkVectorF v) +pattern Mat = VF MatF +pattern UnMat = VF UnMatF +pattern Struct st = VF (StructF st) +pattern Array arr = VF (ArrayF arr) +pattern ArrayLength px1 px2 = VF ( ArrayLengthF px1 px2 ) +pattern NilHList = VF NilHListF +pattern ConsHList = VF ConsHListF + + +-- | Lambda abstraction. +data LamF ( ast :: AugType -> Type ) ( t :: AugType ) where + LamF :: ( ast (Val a) -> ast b ) -> LamF ast ( Val a :--> b ) + +-- | Function application. +data AppF ( ast :: AugType -> Type ) ( t :: AugType ) where + AppF :: ast ( a :--> b ) -> ast a -> AppF ast b + +-- | Haskell-level constants can be embedded into the AST. +data LitF ( ast :: AugType -> Type ) ( t :: AugType ) where + LitF :: PrimTy a => a -> LitF ast (Val a) + +-- | Create an object of the given type from its ID. +-- These are the internal @SPIR-V@ identifiers, in SSA form. +-- Used internally during code-generation (evaluation not possible). +data MkIDF ( ast :: AugType -> Type ) ( t :: AugType ) where + MkIDF :: ( ID, SPIRV.PrimTy ) -> MkIDF ast (Val a) + +-- | Embed a value into the AST. +-- +-- Used internallly to implement evaluation (code-generation not possible). +data ValueF ( ast :: AugType -> Type ) ( t :: AugType ) where + ValueF :: a -> ValueF ast (Val a) + +-- | Coercions (unsafe). +data UnsafeCoerceF ( ast :: AugType -> Type ) ( t :: AugType ) where + UnsafeCoerceF :: UnsafeCoerceF ast (Val a :--> Val b) + + +data IxMonadF ( ast :: AugType -> Type ) ( t :: AugType ) where + -- Indexed monadic operations (for the AST itself). + -- | Indexed /return/ + ReturnF :: IxMonadF ast (Val a :--> Eff i i a) + -- | Indexed /angelic bind/ + BindF :: IxMonadF ast ( Eff i j a :--> ( Val a :--> q j ) :--> q i ) + +-- | @SPIR-V@ primitive operations. +data PrimOpF ( ast :: AugType -> Type ) ( t :: AugType ) where + PrimOpF :: PrimOp op a => Proxy a -> Proxy op -> PrimOpF ast (PrimOpAugType op a) + +-- | Undefined (result of @SPIR-V@'s @OpUndef@). +data UndefinedF ( ast :: AugType -> Type ) ( t :: AugType ) where + UndefinedF :: PrimTy a => UndefinedF ast (Val a) + +-- | Graded mappend to concatenate objects (e.g. two vectors). +data GradedMappendF ( ast :: AugType -> Type ) ( t :: AugType ) where + GradedMappendF + :: ( GradedSemigroup g k, a ~ Grade k g i, b ~ Grade k g j ) + => GradedMappendF ast ( Val a :--> Val b :--> Val (Grade k g (i :: j)) ) + +data ApplicativeF ( ast :: AugType -> Type ) ( t :: AugType ) where + -- | pure/return for applicative functors within the AST. + PureF + :: forall f a v ast + . ( PrimFunc f + , All PrimTyVal (FunArgs a) + , FunRes a ~ Val v, PrimTy v + ) + => Proxy f + -> ast a + -> ApplicativeF ast ( ApplyFAug f a ) + -- | ap/(<*>) for applicative functors within the AST. + ApF + :: forall f a b ast. ( PrimFunc f, PrimTy a ) + => Proxy f + -> ast ( Val (f a) :--> ApplyFAug f b ) + -> ast ( Val (f a) ) + -> ApplicativeF ast ( ApplyFAug f b ) + +-- | Create a vector from its components. +data MkVectorF ( ast :: AugType -> Type ) ( t :: AugType ) where + MkVectorF + :: ( KnownNat n, PrimTy a ) + => V n (ast (Val a)) + -> MkVectorF ast (Val (V n a)) + +data MatF ( ast :: AugType -> Type ) ( t :: AugType ) where + -- | Newtype wrapping for matrices. + MatF + :: forall m n a ast + . ( KnownNat m, KnownNat n ) + => MatF ast ( Val (V n (V m a)) :--> Val (M m n a) ) + + -- | Newtype unwrapping for matrices. + UnMatF + :: forall m n a ast + . ( KnownNat n, KnownNat m ) + => MatF ast ( Val (M m n a) :--> Val (V n (V m a)) ) + +-- | Construct a structure from statically-known parts. +data StructF ( ast :: AugType -> Type ) ( t :: AugType ) where + StructF + :: ( PrimTyMap bs, ASTStructFields ast as bs, bs ~ StructFResultFromArgs as, as ~ StructFArgsFromResult bs ast) + => Struct as + -> StructF ast ( Val (Struct bs) ) + +type family StructFResultFromArgs (as :: [ Symbol :-> Type ]) :: [ Symbol :-> Type ] where + StructFResultFromArgs '[] = '[] + StructFResultFromArgs ((k ':-> ast (Val b)) : as) = ((k ':-> b) : StructFResultFromArgs as) + +type family StructFArgsFromResult (bs :: [ Symbol :-> Type ]) (ast :: AugType -> Type) :: [ Symbol :-> Type ] where + StructFArgsFromResult '[] ast = '[] + StructFArgsFromResult ((k ':-> b) : bs) ast = ((k ':-> ast (Val b)) : StructFArgsFromResult bs ast) + +-- | Construct an array from its components. +data ArrayF ( ast :: AugType -> Type ) ( t :: AugType ) where + ArrayF + :: PrimTy a + => Array n ( ast (Val a) ) + -> ArrayF ast ( Val (Array n a) ) + +-- | Query length of a run-time array. +data ArrayLengthF ( ast :: AugType -> Type ) ( t :: AugType ) where + ArrayLengthF + :: ( KnownSymbol structName, KnownNat arrayPosition ) + => Proxy structName + -> Proxy arrayPosition + -> ArrayLengthF ast ( Eff i i Word32 ) + +-- | Internal HList data type. +-- +-- Only used for providing multiple run-time indices to product optics. +-- See [FIR issue #13](https://gitlab.com/sheaf/fir/issues/13). +data HListF ( ast :: AugType -> Type ) ( t :: AugType ) where + + ConsHListF + :: PrimTy a + => HListF ast ( Val a :--> Val (HList as) :--> Val (HList (a ': as)) ) + + NilHListF + :: HListF ast ( Val ( HList '[] ) ) + +------------------------------------------------------------ +-- displaying + +instance ( ast ~ EGADT cs, MkIDF : Display (LamF ast) where + toTreeArgs as (LamF f) = do + v <- fresh + let var = MkID (v, undefined) + body <- toTreeArgs @_ @ast [] (f var) + return case as of + [] -> Node ("Lam " ++ show v) [body] + _ -> Node ":$" (body : as) +instance Display ast => Display (AppF ast) where + toTreeArgs as (f `AppF` a) = do + at <- toTreeArgs [] a + toTreeArgs (at:as) f +instance Display (LitF ast) where + toTreeArgs = named \ (LitF (a :: ty)) -> + "Lit @" ++ show (primTy @ty) ++ ") " ++ show a +instance Display (MkIDF ast) where + toTreeArgs = named ( \ (MkIDF (v,_)) -> show v ) +instance Display (ValueF ast) where + toTreeArgs = error "internal error: unexpected 'Value' constructor, unsupported in pretty-printing" +instance Display (UnsafeCoerceF ast) where + toTreeArgs = named (const "UnsafeCoerce") +instance Display (IxMonadF ast) where + toTreeArgs = named \case + ReturnF -> "Return" + BindF -> "Bind" +instance Display (PrimOpF ast) where + toTreeArgs = named + ( \( PrimOpF ( _ :: Proxy a ) ( _ :: Proxy op ) ) -> + -- use the Vulkan backend as a default for printing operation names + "PrimOp" ++ show ( SPIRV.op SPIRV.Vulkan ( opName @_ @_ @op @a ) ) + ) +instance Display (UndefinedF ast) where + toTreeArgs = named (const "Undefined") +instance Display (GradedMappendF ast) where + toTreeArgs = named (const "()") +instance Display ast => Display (ApplicativeF ast) where + toTreeArgs as (PureF ( _ :: Proxy f ) a) = do + at <- toTreeArgs [] a + pure $ Node ( "Pure @(" ++ primFuncName @f ++ ")" ) (at:as) + toTreeArgs as (ApF ( _ :: Proxy f ) f a) = do + ft <- toTreeArgs [] f + at <- toTreeArgs [] a + pure $ Node ( "(<*>) @(" ++ primFuncName @f ++ ")" ) (ft:at:as) +instance Display ast => Display (MkVectorF ast) where + toTreeArgs as (MkVectorF (vec :: V n (ast (Val a)))) = do + trees <- toList <$> traverse ( toTreeArgs @_ @ast []) vec + pure $ Node ("Vec" ++ show ( knownValue @n ) ) ( trees ++ as ) +instance Display (MatF ast) where + toTreeArgs = named \case + MatF -> "Mat" + UnMatF -> "UnMat" +instance Display ast => Display (StructF ast) where + toTreeArgs as mkStruct@(StructF elts) = case mkStruct of + ( _ :: StructF ast (Val (Struct bs)) ) -> do + trees <- traverseStructASTs (toTreeArgs @_ @ast []) elts + let + fieldNames :: [ (Maybe ShortText, SPIRV.PrimTy) ] + fieldNames = primTyMap @_ @bs + pure $ Node ("Struct @" ++ show fieldNames) (trees ++ as) +instance Display ast => Display (ArrayF ast) where + toTreeArgs as mkArray@(ArrayF (MkArray vec)) = case mkArray of + ( _ :: ArrayF ast (Val (Array n a)) ) -> do + let + comps = Vector.toList vec + lg = Vector.knownLength' vec ( \px -> show ( natVal px ) ) + trees <- traverse (toTreeArgs []) comps + pure $ + Node + ( "Array @" ++ lg ++ " @" ++ show (primTy @a) ) + ( trees ++ as ) +instance Display (ArrayLengthF ast) where + toTreeArgs as (ArrayLengthF px_name px_pos) = + let + structName :: String + structName = symbolVal px_name + structPos :: Natural + structPos = natVal px_pos + in + pure $ Node ( "ArrayLength @" <> structName <> " @" <> show structPos ) as +instance Display (HListF ast) where + toTreeArgs = named \case + NilHListF -> "NilHList" + ConsHListF -> "ConsHList" diff --git a/src/FIR/AST/Prim.hs-boot b/src/FIR/AST/Prim.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/AST/Prim.hs-boot @@ -0,0 +1,51 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} + +module FIR.AST.Prim where + +-- base +import Data.Kind + ( Type ) + +-- fir +import FIR.AST.Type + ( AugType ) + +------------------------------------------------------------ + +data LamF ( ast :: AugType -> Type ) ( t :: AugType ) +data AppF ( ast :: AugType -> Type ) ( t :: AugType ) +data LitF ( ast :: AugType -> Type ) ( t :: AugType ) +data MkIDF ( ast :: AugType -> Type ) ( t :: AugType ) +data ValueF ( ast :: AugType -> Type ) ( t :: AugType ) +data UnsafeCoerceF ( ast :: AugType -> Type ) ( t :: AugType ) +data IxMonadF ( ast :: AugType -> Type ) ( t :: AugType ) +data PrimOpF ( ast :: AugType -> Type ) ( t :: AugType ) +data UndefinedF ( ast :: AugType -> Type ) ( t :: AugType ) +data GradedMappendF ( ast :: AugType -> Type ) ( t :: AugType ) +data ApplicativeF ( ast :: AugType -> Type ) ( t :: AugType ) +data MkVectorF ( ast :: AugType -> Type ) ( t :: AugType ) +data MatF ( ast :: AugType -> Type ) ( t :: AugType ) +data StructF ( ast :: AugType -> Type ) ( t :: AugType ) +data ArrayF ( ast :: AugType -> Type ) ( t :: AugType ) +data ArrayLengthF ( ast :: AugType -> Type ) ( t :: AugType ) +data HListF ( ast :: AugType -> Type ) ( t :: AugType ) + +type role LamF representational nominal +type role AppF representational nominal +type role LitF phantom nominal +type role MkIDF phantom nominal +type role ValueF phantom nominal +type role UnsafeCoerceF phantom nominal +type role IxMonadF phantom nominal +type role PrimOpF phantom nominal +type role UndefinedF phantom nominal +type role GradedMappendF phantom nominal +type role ApplicativeF representational nominal +type role MkVectorF representational nominal +type role MatF phantom nominal +type role StructF nominal nominal +type role ArrayF nominal nominal +type role ArrayLengthF phantom nominal +type role HListF phantom nominal diff --git a/src/FIR/AST/Type.hs b/src/FIR/AST/Type.hs new file mode 100644 --- /dev/null +++ b/src/FIR/AST/Type.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.AST.Type + +Augmented annotation type for the AST GADT. + +Distinguishes between a partially applied constructor of the AST +and a fully applied constructor of the AST that returns a function. + +Enforces a distinction between pure and stateful operations, +as necessary to be able to write an evaluator. +-} + +module FIR.AST.Type + ( AugType(..), Eff, UnderlyingType + , FunArgs, FunRes, FunTys, MkFunType, ApplyFun + , Nullary, MapVal + , ApplyFAug, MapApplyFAug + ) + where + +-- base +import Data.Kind + ( Type ) + +-- fir +import Control.Monad.Indexed + ( (:=) ) +import {-# SOURCE #-} FIR.ProgramState + ( ProgramState ) + +------------------------------------------------------------ + +infixr 0 :--> +-- | Types of values the AST can hold: concrete values (pure or effectful), and functions. +data AugType + = Val Type + | MkEff Type ProgramState ProgramState -- last parameter must be starting indexed monadic state (McBride formalism) + | AugType :--> AugType + +type Eff i j a = MkEff a j i + +-- | Return the underlying type of an augmented type. +type family UnderlyingType ( t :: AugType ) :: Type where + UnderlyingType (Val ty) = ty + UnderlyingType (Eff i j a) = (a := j) i + UnderlyingType (s :--> t) = UnderlyingType s -> UnderlyingType t + +class ( as ~ FunArgs t, b ~ FunRes t, t ~ MkFunType as b, Nullary b ) + => FunTys (t :: AugType) (as :: [AugType]) (b :: AugType) | t -> as b, as b -> t +instance ( as ~ FunArgs t, b ~ FunRes t, t ~ MkFunType as b, Nullary b ) + => FunTys t as b + +-- | Returns list of arguments of an augmented type. +type family FunArgs (t :: AugType) :: [AugType] where + FunArgs (Val _) = '[] + FunArgs (Eff _ _ _) = '[] + FunArgs (a :--> b) = a ': FunArgs b + +type family FunRes (t :: AugType) :: AugType where + FunRes (a :--> b) = FunRes b + FunRes b = b +type family MkFunType (as :: [AugType]) (b :: AugType) :: AugType where + MkFunType '[] b = b + MkFunType (a ': as) b = a :--> MkFunType as b + +class ( FunArgs a ~ '[], FunRes a ~ a ) => Nullary a +instance ( FunArgs a ~ '[], FunRes a ~ a ) => Nullary a + +type family ApplyFun (a :: AugType) (as :: [AugType]) :: AugType where + ApplyFun a '[] = a + ApplyFun (a :--> b) (a ': as) = ApplyFun b as + +-- | Augment a list of types of values. +type family MapVal (ts :: [Type]) = (as :: [AugType]) | as -> ts where + MapVal '[] = '[] + MapVal (t ': ts) = Val t ': MapVal ts + +------------------------------------------------ +-- Dealing with applying/unapplying functors. + +-- | Apply a functor to an augmented type. +type family ApplyFAug (f :: Type -> Type) (t :: AugType) = ( r :: AugType ) | r -> f t where + ApplyFAug f (Val a ) = Val (f a) + ApplyFAug f (a :--> b ) = ApplyFAug f a :--> ApplyFAug f b + ApplyFAug f (Eff i j a) = Eff i j (f a) + +type family MapApplyFAug (f :: Type -> Type) (fas :: [AugType]) :: [AugType] where + MapApplyFAug _ '[] = '[] + MapApplyFAug f ( Val a ': as ) = Val (f a) ': MapApplyFAug f as diff --git a/src/FIR/Binding.hs b/src/FIR/Binding.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Binding.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Binding + +Keeping track of variable and function bindings at the type-level. +-} + +module FIR.Binding + ( Permission(Read,Write), Permissions + , R, W, RW + , Binding(Variable, Function) + , Var, Fun + , BindingsMap + , FunctionType, FunctionAugType, FunArgTypes + , StoragePermissions + ) + where + +-- base +import Data.Kind + ( Type ) +import GHC.TypeLits + ( Symbol ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.Known + ( Demotable(Demote), Known(known) ) +import Data.Type.List + ( Elem ) +import Data.Type.Map + ( (:->)((:->)), Map ) +import FIR.AST.Type + ( AugType(Val,(:-->)), UnderlyingType ) +import qualified SPIRV.Decoration as SPIRV + ( Decoration(NonReadable, NonWritable) ) +import qualified SPIRV.Storage as SPIRV + +------------------------------------------------------------------------------------------------ +-- bindings: variables, functions, images + +data Permission = Read | Write + deriving stock (Eq, Show) + +type Permissions = [Permission] + +instance Demotable Permission where + type Demote Permission = Permission +instance Known Permission 'Read where + known = Read +instance Known Permission 'Write where + known = Write + +type R = '[ 'Read ] +type W = '[ 'Write ] +type RW = '[ 'Read, 'Write ] + +-- | A binding consists of either: +-- * a variable of given type and permissions (readable/writable), or +-- * a function, with (named) arguments of given types, and given return type. +data Binding where + Variable :: Permissions -> Type -> Binding + Function :: [Symbol :-> Binding] -> Type -> Binding + +-- shorthands +type Var ps a = 'Variable ps a +type Fun as b = 'Function as b + +type BindingsMap = Map Symbol Binding + +type FunctionType as b = UnderlyingType (FunctionAugType as b) + +type family FunArgTypes (as :: BindingsMap) :: [Type] where + FunArgTypes '[] = '[] + FunArgTypes ((_ ':-> a) ': as) = UnderlyingType (BindingAugType a) ': FunArgTypes as + +type family FunctionAugType (as :: BindingsMap) (b :: Type) :: AugType where + FunctionAugType '[] b = Val b + FunctionAugType ((_ ':-> a) ': as) b = BindingAugType a :--> FunctionAugType as b + +-- auxiliary type family (non-exported), +-- used only in the above 'FunctionType' type family +type family BindingAugType (bd :: Binding) :: AugType where + BindingAugType (Var _ a) = Val a + BindingAugType (Fun as b) = FunctionAugType as b + +------------------------------------------------------------------------------------------------ +-- relation to SPIRV storage classes + +type family StoragePermissions (storage :: SPIRV.StorageClass) (decs :: [SPIRV.Decoration Nat]) :: Permissions where + StoragePermissions SPIRV.UniformConstant _ = R + StoragePermissions SPIRV.Input _ = R + StoragePermissions SPIRV.Uniform _ = R + StoragePermissions SPIRV.Output _ = W + StoragePermissions SPIRV.Workgroup decs = PermissionsFromDecorations decs + StoragePermissions SPIRV.CrossWorkgroup decs = PermissionsFromDecorations decs + StoragePermissions SPIRV.Private decs = PermissionsFromDecorations decs + StoragePermissions SPIRV.Function _ = RW -- default value, specific functions can specialise this + StoragePermissions SPIRV.Generic decs = PermissionsFromDecorations decs + StoragePermissions SPIRV.PushConstant _ = R + StoragePermissions SPIRV.AtomicCounter decs = PermissionsFromDecorations decs + StoragePermissions SPIRV.Image decs = PermissionsFromDecorations decs + StoragePermissions SPIRV.StorageBuffer decs = PermissionsFromDecorations decs + StoragePermissions ('SPIRV.RayStorage SPIRV.HitAttribute ) decs = RW + StoragePermissions ('SPIRV.RayStorage SPIRV.ShaderRecordBuffer ) _ = R + StoragePermissions ('SPIRV.RayStorage _ ) decs = PermissionsFromDecorations decs + + +{- +TODO: +Variables with storage class HitAttribute: + +They can be written to only in Intersection execution model, +and read from only in AnyHit and ClosestHit execution models. +-} + +type family PermissionsFromDecorations (decs :: [SPIRV.Decoration Nat]) :: Permissions where + PermissionsFromDecorations decs = + PermissionsFromDecorations' + ( SPIRV.NonReadable `Elem` decs ) + ( SPIRV.NonWritable `Elem` decs ) + +type family PermissionsFromDecorations' (nonReadable :: Bool) (nonWritable :: Bool) :: Permissions where + PermissionsFromDecorations' True True = '[] + PermissionsFromDecorations' True False = W + PermissionsFromDecorations' False True = R + PermissionsFromDecorations' False False = RW diff --git a/src/FIR/Builtin.hs b/src/FIR/Builtin.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Builtin.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Builtin + +This module describes the built-in variables that are provided +for each execution model in SPIR-V. + +For instance, in a vertex shader, one can always write position information +into the built-in variable named @gl_Position@, of type @V 4 Float@. +-} + +module FIR.Builtin where + +-- base +import Control.Arrow + ( second ) +import Data.Proxy + ( Proxy ) +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( Symbol ) +import GHC.TypeNats + ( Nat, SomeNat(SomeNat), someNatVal ) + +-- containers +import Data.Set + ( Set ) +import qualified Data.Set as Set + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( drop ) + +-- fir +import Data.Type.List + ( type (:++:) ) +import Data.Type.Map + ( (:->)((:->)) + , InsertionSort + ) +import FIR.Binding + ( Binding, BindingsMap, Var, R, W ) +import FIR.Layout + ( variableLayout ) +import FIR.Prim.Array + ( Array ) +import FIR.Prim.Struct + ( Struct ) +import FIR.Prim.Types + ( KnownInterface(knownInterface) ) +import Math.Linear + ( V, M ) +import qualified SPIRV.Builtin as SPIRV + ( Builtin(TessLevelInner, TessLevelOuter) + , readBuiltin + ) +import qualified SPIRV.Decoration as SPIRV + ( Decoration(Builtin, Patch, Flat), Decorations ) +import qualified SPIRV.Layout as SPIRV + ( BlockKind(BuiltinBlock) ) +import qualified SPIRV.PrimTy as SPIRV + ( PrimTy, PointerTy(PointerTy), scalars ) +import qualified SPIRV.ScalarTy as SPIRV + ( ScalarTy(..), Width(W64) ) +import qualified SPIRV.Storage as SPIRV + ( StorageClass(..) ) +import SPIRV.Stage + ( TessellationMode(..) + , GeometryInputMode(..) + , ShaderInfo(..) + , ExecutionInfo(..) + , VertexInfo + , TessellationControlInfo + , TessellationEvaluationInfo + , GeometryInfo + , FragmentInfo + , ComputeInfo + , RayShader(..), RayShaderInfo(..) + ) + +import qualified SPIRV.Stage as SPIRV + ( Backend(..), ExecutionModel(..), Stage(..), Shader(..) ) +import qualified SPIRV.Capability as SPIRV + +-------------------------------------------------------------------------- + +type ModelBuiltins (info :: ExecutionInfo Nat stage) + = ( InsertionSort ( ModelBuiltins' info ) :: BindingsMap ) + +type family ModelBuiltins' (info :: ExecutionInfo Nat stage) :: [ Symbol :-> Binding ] where + ModelBuiltins' VertexInfo + = '[ "gl_VertexIndex" ':-> Var R Word32 + , "gl_InstanceIndex" ':-> Var R Word32 + , "gl_Position" ':-> Var W ( V 4 Float ) + , "gl_PointSize" ':-> Var W Float + ] + ModelBuiltins' (TessellationControlInfo inputSize outputSize _) + = '[ "gl_InvocationID" ':-> Var R Word32 + , "gl_PatchVertices" ':-> Var R Word32 + , "gl_PrimitiveID" ':-> Var R Word32 + , "gl_in" + ':-> Var R + ( Array inputSize + ( Struct '[ "gl_Position" ':-> V 4 Float + , "gl_PointSize" ':-> Float + ] + ) + ) + , "gl_out" + ':-> Var W + ( Array outputSize + ( Struct '[ "gl_Position" ':-> V 4 Float + , "gl_PointSize" ':-> Float + ] + ) + ) + , "gl_TessLevelOuter" ':-> Var W ( Array 4 Float ) + , "gl_TessLevelInner" ':-> Var W ( Array 2 Float ) + ] + ModelBuiltins' (TessellationEvaluationInfo inputSize _) + = '[ "gl_TessCoord" ':-> Var R ( V 3 Float ) + , "gl_PatchVertices" ':-> Var R Word32 + , "gl_PrimitiveID" ':-> Var R Word32 + , "gl_in" + ':-> Var R + ( Array inputSize + ( Struct '[ "gl_Position" ':-> V 4 Float + , "gl_PointSize" ':-> Float + ] + ) + ) + , "gl_Position" ':-> Var W ( V 4 Float ) + , "gl_PointSize" ':-> Var W Float + ] + ModelBuiltins' (GeometryInfo inputSize _) + = '[ "gl_PrimitiveID" ':-> Var R Word32 + , "gl_InvocationID" ':-> Var R Word32 + , "gl_in" + ':-> Var R + ( Array inputSize + ( Struct '[ "gl_Position" ':-> V 4 Float + , "gl_PointSize" ':-> Float + ] + ) + ) + , "gl_Position" ':-> Var W ( V 4 Float ) + , "gl_PointSize" ':-> Var W Float + , "gl_Layer" ':-> Var W Word32 + , "gl_ViewportIndex" ':-> Var W Word32 + ] + ModelBuiltins' FragmentInfo + = '[ "gl_Layer" ':-> Var R Word32 + , "gl_ViewportIndex" ':-> Var R Word32 + , "gl_FragCoord" ':-> Var R ( V 4 Float ) + , "gl_PointCoord" ':-> Var R ( V 2 Float ) + , "gl_FrontFacing" ':-> Var R Bool + , "gl_SampleID" ':-> Var R Word32 + , "gl_SamplePosition" ':-> Var R ( V 2 Float ) + , "gl_FragDepth" ':-> Var W Float + ] + ModelBuiltins' ( ComputeInfo _ ) + = '[ "gl_NumWorkgroups" ':-> Var R ( V 3 Word32 ) + , "gl_WorkgroupSize" ':-> Var R ( V 3 Word32 ) + , "gl_WorkgroupID" ':-> Var R ( V 3 Word32 ) + , "gl_LocalInvocationID" ':-> Var R ( V 3 Word32 ) + , "gl_GlobalInvocationID" ':-> Var R ( V 3 Word32 ) + , "gl_LocalInvocationIndex" ':-> Var R Word32 + , "gl_SubgroupInvocationID" ':-> Var R Word32 + , "gl_SubgroupID" ':-> Var R Word32 + , "gl_SubgroupSize" ':-> Var R Word32 + ] + ModelBuiltins' ( KernelInfo _ ) + = '[ "cl_WorkDim" ':-> Var R Word32 + , "cl_GlobalSize" ':-> Var R (V 3 Word32) + , "cl_GlobalInvocationID" ':-> Var R (V 3 Word32) + , "cl_LocalInvocationID" ':-> Var R (V 3 Word32) + , "cl_NumWorkgroups" ':-> Var R (V 3 Word32) + , "cl_WorkgroupID" ':-> Var R (V 3 Word32) + , "cl_GlobalOffset" ':-> Var R (V 3 Word32) + , "cl_GlobalLinearID" ':-> Var R Word32 + , "cl_SubgroupInvocationID" ':-> Var R Word32 + , "cl_SubgroupID" ':-> Var R Word32 + , "cl_SubgroupSize" ':-> Var R Word32 + , "cl_SubgroupMaxSize" ':-> Var R Word32 + ] + ModelBuiltins' ( 'RayShaderInfo ( _ :: RayShaderInfo rayShader ) ) + = RayShaderBuiltins rayShader + +type family RayShaderBuiltins ( shader :: RayShader ) :: [ Symbol :-> Binding ] where + RayShaderBuiltins RayGenerationShader + = '[ "gl_LaunchID" ':-> Var R (V 3 Word32) + , "gl_LaunchSize" ':-> Var R (V 3 Word32) + ] + RayShaderBuiltins IntersectionShader + = '[ "gl_LaunchID" ':-> Var R (V 3 Word32) + , "gl_LaunchSize" ':-> Var R (V 3 Word32) + , "gl_PrimitiveID" ':-> Var R Word32 + , "gl_InstanceID" ':-> Var R Word32 + , "gl_InstanceCustomIndex" ':-> Var R Word32 + , "gl_GeometryIndex" ':-> Var R Word32 + , "gl_WorldRayOrigin" ':-> Var R (V 3 Float) + , "gl_WorldRayDirection" ':-> Var R (V 3 Float) + , "gl_ObjectRayOrigin" ':-> Var R (V 3 Float) + , "gl_ObjectRayDirection" ':-> Var R (V 3 Float) + , "gl_RayTMin" ':-> Var R Float + , "gl_RayTMax" ':-> Var R Float + , "gl_IncomingRayFlags" ':-> Var R Word32 + , "gl_ObjectToWorld" ':-> Var R (M 3 4 Float) + , "gl_WorldToObject" ':-> Var R (M 3 4 Float) + ] + RayShaderBuiltins AnyHitShader = RayShaderBuiltins IntersectionShader :++: + '[ "gl_HitKind" ':-> Var R Word32 ] + RayShaderBuiltins ClosestHitShader = RayShaderBuiltins AnyHitShader + RayShaderBuiltins MissShader + = '[ "gl_LaunchID" ':-> Var R (V 3 Word32) + , "gl_LaunchSize" ':-> Var R (V 3 Word32) + , "gl_WorldRayOrigin" ':-> Var R (V 3 Float) + , "gl_WorldRayDirection" ':-> Var R (V 3 Float) + , "gl_RayTMin" ':-> Var R Float + , "gl_RayTMax" ':-> Var R Float + , "gl_IncomingRayFlags" ':-> Var R Word32 + ] + RayShaderBuiltins CallableShader + = '[ "gl_LaunchID" ':-> Var R (V 3 Word32) + , "gl_LaunchSize" ':-> Var R (V 3 Word32) + ] + +shaderBuiltins :: ShaderInfo Word32 shader -> [ (ShortText, SPIRV.PointerTy) ] +shaderBuiltins VertexShaderInfo + = builtinPointer ( knownInterface @(ModelBuiltins' VertexInfo) ) +shaderBuiltins (TessellationControlShaderInfo inputSize outputSize _) + = case ( someNatVal (fromIntegral inputSize), someNatVal (fromIntegral outputSize) ) of + ( SomeNat ( _ :: Proxy inputSize ), SomeNat ( _ :: Proxy outputSize ) ) + -> builtinPointer ( knownInterface @(ModelBuiltins' (TessellationControlInfo inputSize outputSize 'Nothing)) ) +shaderBuiltins (TessellationEvaluationShaderInfo inputSize _) + = case someNatVal (fromIntegral inputSize) of + SomeNat ( _ :: Proxy inputSize ) + -> builtinPointer ( knownInterface @(ModelBuiltins' (TessellationEvaluationInfo inputSize 'ModeTriangles)) ) -- dummy mode that is not used +shaderBuiltins (GeometryShaderInfo inputSize _) + = case someNatVal (fromIntegral inputSize) of + SomeNat ( _ :: Proxy inputSize ) + -> builtinPointer ( knownInterface @(ModelBuiltins' (GeometryInfo inputSize 'InputModeTriangles)) ) -- another dummy +shaderBuiltins FragmentShaderInfo + = builtinPointer ( knownInterface @(ModelBuiltins' FragmentInfo) ) +shaderBuiltins (ComputeShaderInfo _) + = builtinPointer ( knownInterface @(ModelBuiltins' (ComputeInfo '(1,1,1))) ) -- yet another + +rayShaderBuiltins :: RayShaderInfo shader -> [ (ShortText, SPIRV.PointerTy) ] +rayShaderBuiltins RayGenerationShaderInfo = builtinPointer ( knownInterface @(RayShaderBuiltins RayGenerationShader) ) +rayShaderBuiltins IntersectionShaderInfo = builtinPointer ( knownInterface @(RayShaderBuiltins IntersectionShader) ) +rayShaderBuiltins AnyHitShaderInfo = builtinPointer ( knownInterface @(RayShaderBuiltins AnyHitShader) ) +rayShaderBuiltins ClosestHitShaderInfo = builtinPointer ( knownInterface @(RayShaderBuiltins ClosestHitShader) ) +rayShaderBuiltins MissShaderInfo = builtinPointer ( knownInterface @(RayShaderBuiltins MissShader) ) +rayShaderBuiltins CallableShaderInfo = builtinPointer ( knownInterface @(RayShaderBuiltins CallableShader) ) + +modelBuiltins :: ExecutionInfo Word32 model -> [ (ShortText, SPIRV.PointerTy) ] +modelBuiltins (ShaderExecutionInfo shaderInfo) = shaderBuiltins shaderInfo +modelBuiltins (KernelInfo _) + = builtinPointer ( knownInterface @(ModelBuiltins' (KernelInfo '(1,1,1))) ) -- dummy again +modelBuiltins (RayShaderInfo rayInfo) = rayShaderBuiltins rayInfo + +builtinPointer + :: [ (ShortText, (SPIRV.PrimTy, SPIRV.StorageClass)) ] + -> [ (ShortText, SPIRV.PointerTy) ] +builtinPointer = map + ( second $ \ (ty, storage) + -> SPIRV.PointerTy storage (variableLayout SPIRV.BuiltinBlock storage ty) ty + ) + +-------------------------------------------------------------------------- +-- decoration of builtins +-- slight indirection to account for complexities with 'gl_in', 'gl_out' +-- (that is, inputs/outputs that are given as arrays of structs) + +-- | Decorations of a built-in variable, used in an entry point with the given execution model. +builtinDecorations :: SPIRV.ExecutionModel -> ShortText -> SPIRV.PointerTy -> SPIRV.Decorations +builtinDecorations model builtin ( SPIRV.PointerTy storage _ ty ) + = builtinNameDecorations builtin <> flat + where + -- Integer and double-precision fragment shader inputs must be decorated with 'Flat'. + flat :: SPIRV.Decorations + flat + | model == SPIRV.Stage ( SPIRV.ShaderStage SPIRV.FragmentShader ) + , storage == SPIRV.Input + , any needsFlat ( SPIRV.scalars ty ) + = Set.singleton SPIRV.Flat + | otherwise + = Set.empty + needsFlat :: SPIRV.ScalarTy -> Bool + needsFlat ( SPIRV.Integer {} ) = True + needsFlat ( SPIRV.Floating SPIRV.W64 ) = True + needsFlat _ = False + +builtinNameDecorations :: ShortText -> SPIRV.Decorations +builtinNameDecorations "gl_TessLevelInner" + = Set.fromAscList [ SPIRV.Builtin SPIRV.TessLevelInner, SPIRV.Patch ] +builtinNameDecorations "gl_TessLevelOuter" + = Set.fromAscList [ SPIRV.Builtin SPIRV.TessLevelOuter, SPIRV.Patch ] +builtinNameDecorations perVertex + | perVertex `elem` [ "gl_in", "gl_out" ] + -- workaround: in this case the 'Builtin' decoration is applied when we create the relevant struct + = Set.empty +builtinNameDecorations builtin + = maybe + Set.empty + ( Set.singleton . SPIRV.Builtin ) + ( SPIRV.readBuiltin builtin ) + +builtinCapabilities :: SPIRV.Backend -> ShortText -> Set SPIRV.Capability +builtinCapabilities bk builtinName + | builtinName `elem` [ "gl_ClipDistance", "gl_CullDistance" ] + = Set.singleton SPIRV.ClipDistance + | builtinName `elem` [ "gl_SampleID", "gl_SamplePosition" ] + = Set.singleton SPIRV.SampleRateShading + | isSubgroupBuiltin ( ShortText.drop 3 builtinName ) + = case bk of + SPIRV.Vulkan -> Set.singleton SPIRV.GroupNonUniform + SPIRV.OpenCL -> Set.singleton SPIRV.ComputeKernel + | otherwise + = Set.empty + +isSubgroupBuiltin :: ShortText -> Bool +isSubgroupBuiltin "SubgroupInvocationID" = True +isSubgroupBuiltin "SubgroupID" = True +isSubgroupBuiltin "SubgroupSize" = True +isSubgroupBuiltin "SubgroupMaxSize" = True +isSubgroupBuiltin _ = False diff --git a/src/FIR/Definition.hs b/src/FIR/Definition.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Definition.hs @@ -0,0 +1,508 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Definition + +In this module, a definition refers to a type-level annotation the user +can/must provide to describe the interface of a SPIR-V module. + +For example, a typical fragment shader for mapping a texture could +declare the following definitions: + +> type FragmentDefs = +> '[ "in_colour" ':-> Input '[ Location 0 ] (V 4 Float) +> , "in_uv" ':-> Input '[ Location 1 ] (V 2 Float) +> , "texture" ':-> Texture2D '[ Binding 0, DescriptorSet 0 ] (RGBA8 UNorm) +> , "out_colour" ':-> Output '[ Location 0 ] (V 4 Float) +> , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment +> ] +> +> fragment :: ShaderModule "main" FragmentShader FragmentDefs _endState +> fragment = ... + +There are three types of definitions: + + * global variables that belong to the interface (inputs, outputs, uniform constants such as textures, etc), + * functions that are going to be defined, + * entry points that are going to be defined. + +In the above example all definitions are of the first kind, +save for the last definition which declares an entry point. + +The definitions allow the user to specify, within a SPIR-V module, detailed information about the interface. + +For instance, in the above example, the inputs/outputs are annotated with location information, +whereas the texture (a uniform constant) is annotated with its binding and descriptor set. +See "FIR.Layout" for further details concerning such annotations. + +On the other hand, the execution model (in this case the fragment shader) is given its execution modes +(in this case, specifying that the origin for the coordinate system used by fragments is +in the upper-left corner). + +See also "FIR.Validation.Definitions", which provides type families +used to validate user-provided definitions. +-} + +module FIR.Definition where + +-- base +import Data.Kind + ( Type ) +import GHC.Generics + ( Generic ) +import GHC.TypeLits + ( Symbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat ) + +-- containers +import Data.Map + ( Map ) +import qualified Data.Map.Strict as Map + ( toList ) +import Data.Set + ( Set ) +import qualified Data.Set as Set + ( fromList ) + +-- lens +import Control.Lens + ( Lens', lens, at + , set, over + ) + +-- generic-monoid +import Data.Monoid.Generic + ( GenericSemigroup(..), GenericMonoid(..) ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- fir +import CodeGen.State + ( CGContext(..), emptyContext ) +import Data.Type.Known + ( Demotable(Demote), Known(known), knownValue ) +import Data.Type.Map + ( (:->)((:->)) + , Insert, Union + , InsertWithInsert + ) +import FIR.Binding + ( Binding(Variable), StoragePermissions ) +import qualified FIR.Binding as Binding + ( Binding(Function) ) +import FIR.Layout + ( variableLayout ) +import FIR.Prim.Image + ( Image, knownImage, ImageProperties ) +import FIR.Prim.Types + ( PrimTy, primTy ) +import FIR.ProgramState + ( ProgramState(ProgramState), CFGState(..) + , Definedness(Declared) + , FunctionInfo(FunctionInfo) + , EntryPointInfo(EntryPointInfo), TLInterfaceVariable + ) +import qualified FIR.ProgramState as ProgramState + ( FunctionContext(TopLevel) ) +import FIR.Validation.Bindings + ( InsertEntryPointInfo, EntryPointsBackend ) +import FIR.Validation.ExecutionModes + ( ValidateExecutionModes ) +import qualified SPIRV.Capability as SPIRV + ( Capability ) +import qualified SPIRV.Control as SPIRV + ( FunctionControl ) +import qualified SPIRV.Decoration as SPIRV + ( Decoration, Decorations ) +import qualified SPIRV.ExecutionMode as SPIRV + ( ExecutionMode, ExecutionModes ) +import qualified SPIRV.Extension as SPIRV + ( Extension ) +import qualified SPIRV.Image as SPIRV + ( Image(imageUsage), ImageUsage(Sampled) ) +import qualified SPIRV.Layout as SPIRV + ( BlockKind(UserBlock) ) +import qualified SPIRV.PrimTy as SPIRV + ( PrimTy(Image, SampledImage) + , PointerTy(PointerTy) + ) +import qualified SPIRV.Requirements as SPIRV + ( globalCapabilities, globalExtensions + , executionModelCapabilities, executionModelExtensions + ) +import qualified SPIRV.Stage as SPIRV + ( ExecutionModel, ExecutionInfo, Backend(..), backendOf ) +import qualified SPIRV.Storage as SPIRV + ( StorageClass ) +import qualified SPIRV.Version as SPIRV + ( Version(..) ) + +-------------------------------------------------------------------------- +-- annotating top-level definitions with necessary information +-- for instance, annotating layout information + +-- | Definitions are top-level type-level annotations which provide +-- the necessary information for a SPIR-V module. +data Definition where + Global :: SPIRV.StorageClass -> [ SPIRV.Decoration Nat ] -> Type -> Definition + Function :: SPIRV.FunctionControl -> [Symbol :-> Binding] -> Type -> Definition + EntryPoint :: [ SPIRV.ExecutionMode Nat ] -> SPIRV.ExecutionModel -> Definition + +data Annotate + = AnnotateGlobal ( SPIRV.PointerTy, SPIRV.Decorations ) + | AnnotateFunction SPIRV.FunctionControl + | AnnotateEntryPoint ( SPIRV.ExecutionModel, SPIRV.ExecutionModes ) + +data Annotations + = Annotations + { globalAnnotations :: Map ShortText ( SPIRV.PointerTy, SPIRV.Decorations ) + , functionAnnotations :: Map ShortText SPIRV.FunctionControl + , executionAnnotations :: Map (ShortText, SPIRV.ExecutionModel) SPIRV.ExecutionModes + , annotationCapabilities :: Set SPIRV.Capability + , annotationExtensions :: Set SPIRV.Extension + } + deriving stock (Show, Eq, Generic) + deriving Semigroup via GenericSemigroup Annotations + deriving Monoid via GenericMonoid Annotations + +_globalAnnotations :: Lens' Annotations (Map ShortText (SPIRV.PointerTy, SPIRV.Decorations)) +_globalAnnotations = lens globalAnnotations ( \anns v -> anns { globalAnnotations = v } ) + +_globalAnnotation :: ShortText -> Lens' Annotations (Maybe (SPIRV.PointerTy, SPIRV.Decorations)) +_globalAnnotation name = _globalAnnotations . at name + +_functionAnnotations :: Lens' Annotations (Map ShortText SPIRV.FunctionControl) +_functionAnnotations = lens functionAnnotations ( \anns v -> anns { functionAnnotations = v } ) + +_functionAnnotation :: ShortText -> Lens' Annotations (Maybe SPIRV.FunctionControl) +_functionAnnotation name = _functionAnnotations . at name + +_executionAnnotations :: Lens' Annotations (Map (ShortText, SPIRV.ExecutionModel) SPIRV.ExecutionModes) +_executionAnnotations = lens executionAnnotations ( \anns v -> anns { executionAnnotations = v } ) + +_executionAnnotation + :: ShortText -> SPIRV.ExecutionModel + -> Lens' Annotations (Maybe SPIRV.ExecutionModes) +_executionAnnotation name em = _executionAnnotations . at (name, em) + +_annotationCapabilities :: Lens' Annotations (Set SPIRV.Capability) +_annotationCapabilities = lens annotationCapabilities ( \anns v -> anns { annotationCapabilities = v } ) + +_annotationExtensions :: Lens' Annotations (Set SPIRV.Extension) +_annotationExtensions = lens annotationExtensions ( \anns v -> anns { annotationExtensions = v } ) + +-------------------------------------------------------------------------- +-- reification of type-level definitions/annotations + +initialCGContext :: forall defs. KnownDefinitions defs => CGContext +initialCGContext = + let Annotations {..} = annotations @defs + bk = entryPointsBackend executionAnnotations + in emptyContext + { userGlobals = globalAnnotations + , userFunctions = functionAnnotations + , userEntryPoints = executionAnnotations + , userCapabilities = annotationCapabilities + , userExtensions = annotationExtensions + , backend = bk + , spirvVersion = defaultSPIRVVersion bk + } + +-- | Default SPIR-V version for a backend. +defaultSPIRVVersion :: SPIRV.Backend -> SPIRV.Version +defaultSPIRVVersion SPIRV.Vulkan = SPIRV.Version 1 5 +defaultSPIRVVersion SPIRV.OpenCL = SPIRV.Version 1 2 + +entryPointsBackend :: Map (ShortText, SPIRV.ExecutionModel) SPIRV.ExecutionModes -> SPIRV.Backend +entryPointsBackend eps = case Map.toList eps of + [] -> error "internal error: empty list of entry points" + ( ( (_, em), _ ) : _ ) -> SPIRV.backendOf em + +instance Demotable Definition where + type Demote Definition = Annotate + +-- workaround for image types being opaque and not having a Haskell-level counterpart +instance {-# OVERLAPPING #-} + ( Known ImageProperties props + , Known SPIRV.StorageClass storage + , Known [SPIRV.Decoration Nat] decs + ) + => Known Definition ('Global storage decs (Image props)) + where + known = AnnotateGlobal + ( globalPointer ( knownValue @storage ) imgTy + , Set.fromList ( knownValue @decs ) + ) + where imgTy :: SPIRV.PrimTy + imgTy = case knownImage @props of + img -> case SPIRV.imageUsage img of + Just SPIRV.Sampled -> SPIRV.SampledImage img + _ -> SPIRV.Image img + +instance ( PrimTy ty, Known SPIRV.StorageClass storage, Known [SPIRV.Decoration Nat] decs ) + => Known Definition ('Global storage decs ty) + where + known = AnnotateGlobal + ( globalPointer ( knownValue @storage ) ( primTy @ty ) + , Set.fromList ( knownValue @decs ) + ) + +-- | The pointer type of a user-defined global variable. +globalPointer :: SPIRV.StorageClass -> SPIRV.PrimTy -> SPIRV.PointerTy +globalPointer storage ty = SPIRV.PointerTy storage ( variableLayout SPIRV.UserBlock storage ty ) ty + +instance Known SPIRV.FunctionControl control + => Known Definition ('Function control args res) + where + known = AnnotateFunction ( knownValue @control ) + +instance ( Known SPIRV.ExecutionModel stage, Known [SPIRV.ExecutionMode Nat] modes ) + => Known Definition ('EntryPoint modes stage) + where + known = AnnotateEntryPoint + ( knownValue @stage + , Set.fromList ( knownValue @modes ) + ) + +class KnownDefinitions (defs :: [ Symbol :-> Definition ]) where + annotations :: Annotations + +instance KnownDefinitions '[] where + annotations = mempty + +instance ( Known Symbol k, Known Definition def, KnownDefinitions defs) + => KnownDefinitions ((k ':-> def) ': defs) + where + annotations + = let anns = annotations @defs + k = knownValue @k + in case knownValue @def of + AnnotateGlobal x@(SPIRV.PointerTy _ _ ty, _) + -> set ( _globalAnnotation k ) (Just x) + . over _annotationCapabilities (SPIRV.globalCapabilities ty <>) + . over _annotationExtensions (SPIRV.globalExtensions ty <>) + $ anns + AnnotateFunction x + -> set ( _functionAnnotation k ) (Just x) anns + AnnotateEntryPoint (s, x) + -> set ( _executionAnnotation k s) (Just x) + . over _annotationCapabilities (SPIRV.executionModelCapabilities s <>) + . over _annotationExtensions (SPIRV.executionModelExtensions s <>) + $ anns + +-------------------------------------------------------------------------- +-- computing type-level states from type-level definitions + +type Definitions = [ Symbol :-> Definition ] +-- recall: +-- type TLInterfaceVariable = ( [SPIRV.Decoration Nat], Type ) +type TriagedDefinitions = + ( [ Symbol :-> FunctionInfo ] + , [ Symbol :-> (SPIRV.ExecutionModel, [ SPIRV.ExecutionMode Nat ]) ] + , [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] + ) + +-- | Computes the starting indexed monadic state, from user-supplied +-- list of top level 'Definition's. +-- +-- Performs a limited amount of validation: +-- +-- * Checks there are no duplicate declarations. +-- * Validates entry point execution modes. +-- +-- Validation of global variables (and their layout) is done separately, +-- see "FIR.Module". +type StartState (defs :: Definitions) + = ( StartStateFromTriage ( TrieDefinitions defs ) :: ProgramState ) + +-- | Helper computation of the starting indexed monadic state, from triaged definitions. +-- +-- * The insertion sorts will throw an error if there are duplicates. +-- * The computation of entry point infos performs validation of entry points. +-- * Validation of bindings is done separately, see "FIR.Module". +type family StartStateFromTriage + ( triaged :: TriagedDefinitions ) + :: ProgramState where + StartStateFromTriage '( funs, eps, globals ) + = 'ProgramState + ( InsertionSortGlobals globals ) -- checks for duplicate globals + ProgramState.TopLevel + ( 'CFGState 0 ) + funs + ( EntryPointInfos globals eps ) -- validates entry points and checks for duplicates + globals + '[] -- no ray queries have been started + ( EntryPointsBackend eps ) + +-- | Perform triage of user-supplied definitions, +-- so that different kinds of definition can be handled separately. +type family TrieDefinitions ( defs :: Definitions ) :: TriagedDefinitions where + TrieDefinitions '[] = '( '[], '[], '[] ) + TrieDefinitions + ( ( k ':-> Global storage decs ty ) ': defs ) + = TrieInsertGlobal k storage '(decs, ty) (TrieDefinitions defs) + TrieDefinitions + ( ( k ':-> Function fc as b ) ': defs ) + = TrieInsertFunctionInfo k ('FunctionInfo as b fc 'Declared) (TrieDefinitions defs) + TrieDefinitions + ( ( k ':-> EntryPoint modes em ) ': defs ) + = TrieAddEntryPoint k '(em, modes) (TrieDefinitions defs) + -- in this case, insertion sorting (including duplicate checking) + -- happens later (after computing entry point infos) + +type family TrieInsertGlobal + ( k :: Symbol ) + ( storage :: SPIRV.StorageClass ) + ( global :: TLInterfaceVariable ) + ( triaged :: TriagedDefinitions ) + :: TriagedDefinitions + where + TrieInsertGlobal k storage glob '( funs, eps, globs ) + = '( funs, eps, InsertGlobal k storage glob globs ) + +type family InsertGlobal + ( k :: Symbol ) + ( storage :: SPIRV.StorageClass ) + ( global :: TLInterfaceVariable ) + ( globals :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] ) + :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] + where + InsertGlobal k storage global '[] = '[ storage ':-> '[ k ':-> global ] ] + InsertGlobal k storage global + ( (storage ':-> globals ) ': others ) + = ( storage ':-> Insert k global globals ) ': others + InsertGlobal k storage global ( others ': globals ) + = others ': InsertGlobal k storage global globals + +type family TrieInsertFunctionInfo + ( k :: Symbol ) + ( nfo :: FunctionInfo ) + ( triaged :: TriagedDefinitions ) + :: TriagedDefinitions + where + TrieInsertFunctionInfo k nfo '( funs, eps, globs ) + = '( Insert k nfo funs, eps, globs ) + +type family TrieAddEntryPoint + ( k :: Symbol ) + ( ep :: ( SPIRV.ExecutionModel, [SPIRV.ExecutionMode Nat] ) ) + ( triaged :: TriagedDefinitions ) + :: TriagedDefinitions + where + TrieAddEntryPoint k ep '( funs, eps, globs ) + = '( funs, ( k ':-> ep) ': eps, globs ) + +type family EntryPointInfos + ( globals :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] ) + ( entryPoints :: [ Symbol :-> (SPIRV.ExecutionModel, [ SPIRV.ExecutionMode Nat ]) ] ) + :: [ Symbol :-> EntryPointInfo ] + where + EntryPointInfos _ '[] = '[] + EntryPointInfos globals ( ( k ':-> '( em, modes ) ) ': eps ) + = InsertMaybeEntryPointInfo k globals + ( ValidateExecutionModes k em modes ) + ( EntryPointInfos globals eps ) + +type family DefinitionFunctions + ( defs :: [ Symbol :-> Definition ] ) + :: [Symbol :-> FunctionInfo] + where + DefinitionFunctions '[] = '[] + DefinitionFunctions ( (k ':-> Function fc as b) ': defs ) + = Insert k ('FunctionInfo as b fc Declared) (DefinitionFunctions defs) + DefinitionFunctions ( _ ': defs ) -- not a function + = DefinitionFunctions defs + + +type family InsertMaybeEntryPointInfo + ( k :: Symbol ) + ( globals :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] ) + ( nfo :: Maybe (SPIRV.ExecutionInfo Nat stage) ) + ( nfos :: [ Symbol :-> EntryPointInfo ] ) + :: [ Symbol :-> EntryPointInfo ] + where + InsertMaybeEntryPointInfo _ _ 'Nothing _ + -- 'ValidateExecutionModes' never returns Nothing, it throws a type error instead + -- this trick forces evaluation of 'ValidateExecutionModes' + -- ( this fixes [issue #43](https://gitlab.com/sheaf/fir/issues/43) ) + = TypeError ( Text "Invalid entry point execution modes (unreachable)" ) + InsertMaybeEntryPointInfo k globals ('Just nfo) nfos + = InsertEntryPointInfo k + ( 'EntryPointInfo nfo globals 'Declared ) + nfos + +-- | Grabs the variables in the given definition. +-- +-- This is a workaround for the fact that shader interfaces are not kept track of +-- at the type level. +-- This is permissible as long as the interface for the entry-point consists precisely +-- of the 'Input'/'Output' variables provided in the top-level annotation. +-- See [FIR issue #51](https://gitlab.com/sheaf/fir/issues/51). +type family Variables + ( defs :: [Symbol :-> Definition] ) + :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] + where + Variables '[] = '[] + Variables ( ( varName ':-> Global storage decs ty) ': defs ) + = InsertWithInsert storage varName '(decs,ty) ( Variables defs ) + Variables ( _ ': defs ) = Variables defs + + +type family InsertionSortGlobals + ( globals :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] ) + :: [ Symbol :-> Binding ] + where + InsertionSortGlobals '[] = '[] + InsertionSortGlobals ( ( storage ':-> globals ) ': others ) + = Union ( InsertionSortGlobalsWith storage globals ) ( InsertionSortGlobals others ) + +type family InsertionSortGlobalsWith + ( storage :: SPIRV.StorageClass ) + ( globals :: [ Symbol :-> TLInterfaceVariable ] ) + :: [ Symbol :-> Binding ] + where + InsertionSortGlobalsWith _ '[] = '[] + InsertionSortGlobalsWith storage ( ( k ':-> '( decs, ty ) ) ': globals ) + = Insert k + ( Variable (StoragePermissions storage decs) ty ) + ( InsertionSortGlobalsWith storage globals ) + + +type family StartBindings (defs :: [ Symbol :-> Definition ]) :: [ Symbol :-> Binding ] where + StartBindings '[] + = '[] + StartBindings ((k ':-> Global storage decs ty) ': defs) + = Insert k (Variable (StoragePermissions storage decs) ty) (StartBindings defs) + ---- ^^^^^ TODO: we probably don't want to add all of these storage classes to the list of bindings? + StartBindings ((k ':-> _) ': defs) + = StartBindings defs + +type family EndBindings (defs :: [ Symbol :-> Definition ]) :: [ Symbol :-> Binding ] where + EndBindings '[] + = '[] + EndBindings ((k ':-> Global storage decs ty) ': defs) + = Insert k (Variable (StoragePermissions storage decs) ty) (EndBindings defs) + EndBindings ((k ':-> Function _ as b) ': defs) + = Insert k (Binding.Function as b) (EndBindings defs) + EndBindings (_ ': defs) + = EndBindings defs diff --git a/src/FIR/Generics.hs b/src/FIR/Generics.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Generics.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module FIR.Generics (FromGenericProduct(..)) where + +-- base +import Prelude + hiding ( undefined ) +import Data.Typeable +import Data.Kind + ( Type ) +import GHC.TypeLits ( Symbol, KnownSymbol ) + +-- variant +import Data.Variant.EGADT + ( pattern VF ) + +-- fir +import Data.Type.Map + +import FIR.AST.Prim +import FIR.AST.Type + +import FIR.Prim.Struct +import FIR.Prim.Types + ( PrimTyMap ) + +import FIR.AST + +-- generics-sop +import Generics.SOP (NP(..), I(..), K(..)) +import qualified Generics.SOP as SOP + +------------------------------------------------ +-- Generic deriving for Syntactic + +-- | Newtype to automatically derive Syntactic for instances generically for product types. +-- +-- Example +-- +-- @ +-- data MinMax = MinMax Float Float +-- deriving (GHC.Generic, SOP.Generic) +-- deriving Syntactic via (FromGenericProduct MinMax ["min", "max"]) +-- @ +type FromGenericProduct :: Type -> [Symbol] -> Type +newtype FromGenericProduct t xs = FromGenericProduct t + +instance forall (t :: Type) (ts :: [Type]) (xs :: [Symbol]) (zgs :: [Symbol :-> Type]) (zgs' :: [Symbol :-> Type]). + ( SOP.IsProductType t ts + + , zgs ~ ZipGenericSyntactic xs ts + , zgs' ~ ZipGenericSyntactic' xs ts + + , PrimTyMap zgs + + , ASTStructFields AST zgs' zgs + , StructFResultFromArgs zgs' ~ zgs + , StructFArgsFromResult zgs AST ~ zgs' + + , SOP.AllZip SyntacticRel xs ts + , SOP.All Typeable ts + , SOP.All KnownSymbol xs + ) => Syntactic (FromGenericProduct t xs) where + type Internal (FromGenericProduct t xs) = Val (Struct (ZipGenericSyntactic xs (SOP.ProductCode t))) + + toAST :: FromGenericProduct t xs -> AST (Val (Struct (ZipGenericSyntactic xs ts))) + toAST (FromGenericProduct a) + = Struct (npToStruct (mkNP @xs) (SOP.productTypeFrom a)) + where + npToStruct :: forall ns ys + . (SOP.AllZip SyntacticRel ns ys) + => NP (K ()) ns + -> NP I ys + -> Struct (ZipGenericSyntactic' ns ys) + npToStruct Nil Nil = End + npToStruct (_ SOP.:* xs) (SOP.I y SOP.:* ys) = toAST y :& npToStruct xs ys + + fromAST :: AST (Val (Struct (ZipGenericSyntactic xs ts))) -> FromGenericProduct t xs + fromAST (VF (StructF struct)) = FromGenericProduct $ + SOP.productTypeTo @t (structToNp (mkNP @xs) struct) + where + structToNp :: forall (ns :: [Symbol]) ys + . ( SOP.AllZip SyntacticRel ns ys ) + => NP (K ()) ns + -> Struct (ZipGenericSyntactic' ns ys) + -> NP I ys + structToNp Nil End = Nil + structToNp ((_ :: (K () (n :: Symbol))) :* xs) (y :& ys) + = I (fromAST y) :* structToNp xs ys + fromAST _ = error "impossible" + +mkNP :: forall ns. SOP.SListI ns => NP (K ()) ns +mkNP = case SOP.sList @ns of + SOP.SNil -> Nil + SOP.SCons -> K () SOP.:* mkNP + +type family ZipGenericSyntactic (xs :: [Symbol]) (ys :: [Type]) where + ZipGenericSyntactic '[] '[] = '[] + ZipGenericSyntactic (x : xs) (y : ys) = (x ':-> InternalType y) : ZipGenericSyntactic xs ys + +type family ZipGenericSyntactic' (xs :: [Symbol]) (ys :: [Type]) where + ZipGenericSyntactic' '[] '[] = '[] + ZipGenericSyntactic' (x : xs) (y : ys) = (x ':-> AST (Val y)) : ZipGenericSyntactic' xs ys + +class (Val y ~ Internal y, Syntactic y) => SyntacticRel x y +instance (Val y ~ Internal y, Syntactic y) => SyntacticRel x y + diff --git a/src/FIR/Layout.hs b/src/FIR/Layout.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Layout.hs @@ -0,0 +1,812 @@ +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fconstraint-solver-iterations=8 #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + +{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} -- for some reason this needs to be bumped with GHC 9.14 + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Layout + +This module is concerned with the memory layout of types for use with Vulkan. +There are three different situations one needs to account for: + + - uniform buffers must form a struct or array of structs, + laid out according to the Extended alignment rules, + - push constants and storage buffers must form a struct or array of structs, + laid out according to the Base alignment rules, + - vertex input data is specified with Location and Component information. + +This module automatically performs layout of types according to the above rules. +See also "FIR.Validation.Layout", which performs validation of user-supplied layouts. + +In the first two situations above, the shader that makes use of such structs +must provide explicit Offset and Stride decorations. These offsets +are computed by this module to avoid the user needing to manually specify them. + +In the last situation, per-vertex/per-instance data is laid out in locations, +for use by the vertex shader. See "FIR.Validation.Layout". + +For further reference, see: + + - SPIR-V specification, 2.16.2 "Validation Rules for Shader Capabilities", bullet point 3, + - SPIR-V specification, 2.18.1 "Memory Layout", + - Vulkan specification, 14.1.4 "Location Assignment", and 14.1.5 "Component Assignment", + - Vulkan specification, 14.5.2 "Descriptor Set Interface", and 14.5.4 "Offset and Stride Assignment". + +-} + +module FIR.Layout + ( Layout(..), Components + , Poke(..), pokeArrayOff, pokeArray + , MemberOffset, memberOffset + , variableLayout + , arrayStride, memberLayoutDecorations + , roundUp, nextAligned + ) + where + +-- base +import Control.Monad + ( foldM_ ) +import Data.Int + ( Int8, Int16, Int32, Int64 ) +import Data.Kind + ( Type ) +import Data.Maybe + ( isJust ) +import Data.Proxy + ( Proxy(..) ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import Data.Word + ( Word8, Word16, Word32, Word64 ) +import Foreign.Ptr + ( Ptr, castPtr, plusPtr ) +import qualified Foreign.Storable as Storable + ( poke ) +import GHC.TypeLits + ( Symbol, SomeSymbol(..) + , TypeError, ErrorMessage(..) + , someSymbolVal + ) +import GHC.TypeNats + ( Nat, KnownNat, SomeNat(..) + , type (<=), type (<=?), type (+), type (*) + , Div + , someNatVal + ) +import Numeric.Natural + ( Natural ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- containers +import qualified Data.Set as Set + ( empty, fromList, insert ) + +-- half +import Numeric.Half + ( Half, fromHalf ) + +-- mtl +import Control.Monad.Except + ( MonadError, throwError ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( pack ) + +-- fir +import Data.Constraint.All + ( AllDict(ConsDict) + , All(allDict) + ) +import Data.Type.Known + ( Known, knownValue ) +import Data.Type.Map + ( (:->)((:->)), Value ) +import Data.Type.Nat + ( NextPositivePowerOf2, RoundUp ) +import Data.Type.POrd + ( POrd(Max) ) +import FIR.Prim.Array + ( Array(..) ) +import FIR.Prim.RayTracing + ( AccelerationStructure(..) ) +import FIR.Prim.Struct + ( Struct(..) + , LocationSlot(LocationSlot) + , FieldKind(..) + , StructFieldKind(fieldKind) + ) +import FIR.Prim.Types + ( ScalarTy, PrimTyMap(..), SPrimTyMap(..) + , SPrimTy(..) + , primTySing + ) +import qualified FIR.Prim.Types as Prim + ( PrimTy ) +import Math.Algebra.Class + ( AdditiveGroup, Semiring ) +import Math.Linear + ( V, M(unM) ) +import qualified SPIRV.Decoration as SPIRV +import qualified SPIRV.Layout as SPIRV +import qualified SPIRV.PrimTy as SPIRV +import SPIRV.PrimTy + ( PrimTy(..) ) -- field accessors for named field puns +import qualified SPIRV.ScalarTy as SPIRV +import qualified SPIRV.Storage as SPIRV + ( StorageClass ) +import qualified SPIRV.Storage as Storage + +-------------------------------------------------------------------------------------------- + +-- | Specification of alignment requirements. +data Layout + = Base -- ^ Layout used for storage buffers and push constants. + | Extended -- ^ Layout used for uniform buffers. + | Locations -- ^ Layout used for vertex binding input data. + deriving stock ( Eq, Show ) + +-- | Type-class for data that can be stored in memory, +-- following the specified alignment requirements. +class ( KnownNat (SizeOf lay a) + , KnownNat (Alignment lay a) + ) => Poke a (lay :: Layout) where + + type SizeOf lay a :: Nat + sizeOf :: Word32 + sizeOf = knownValue @(SizeOf lay a) + + type Alignment lay a :: Nat + alignment :: Word32 + alignment = knownValue @(Alignment lay a) + + poke :: Ptr a -> a -> IO () + +type Components a = ( SizeOf Locations a `Div` 4 :: Nat ) + +type family SumRoundedUpSizes (lay :: Layout) (as :: [fld :-> Type]) (acc :: Nat) :: Nat where + SumRoundedUpSizes _ '[] acc = acc + SumRoundedUpSizes lay ( ( _ ':-> a ) ': as ) acc = SumRoundedUpSizes lay as ( ( acc `RoundUp` Alignment lay a ) + SizeOf lay a ) + +-- | The offset, in bytes, of a member of a structure, in a layout. +type family MemberOffset (lay :: Layout) (k :: Symbol) (struct :: Type) :: Nat where + MemberOffset lay k ( Struct as ) = MemberOffsetFrom lay k as 0 + +type family MemberOffsetFrom (lay :: Layout) (k :: Symbol) (as :: [Symbol :-> Type]) (acc :: Nat) :: Nat where + MemberOffsetFrom lay k ( ( k ':-> a ) ': _ ) acc = + acc `RoundUp` Alignment lay a + MemberOffsetFrom lay k ( ( _ ':-> a ) ': as ) acc = + MemberOffsetFrom lay k as ( ( acc `RoundUp` Alignment lay a ) + SizeOf lay a ) + MemberOffsetFrom _ k '[] _ = + TypeError ( Text "No structure member named " :<>: ShowType k :<>: Text "." ) + +-- | 'MemberOffset', as a value. +memberOffset + :: forall lay k struct. KnownNat ( MemberOffset lay k struct ) => Word32 +memberOffset = knownValue @( MemberOffset lay k struct ) + +type family MaximumAlignment (lay :: Layout) (as :: [fld :-> Type]) :: Nat where + MaximumAlignment _ '[] = 1 + MaximumAlignment lay ( ( _ ':-> a ) ': as ) = Max ( Alignment lay a ) ( MaximumAlignment lay as ) + +roundUp :: Integral a => a -> a -> a +roundUp n r = (n + r) - ( 1 + ( (n + r - 1) `mod` r ) ) + +-- | Write elements to an array, whose start is given by a pointer. +pokeArray :: forall a lay. ( Poke a lay, Poke (Array 1 a) lay ) => Ptr a -> [a] -> IO () +pokeArray ptr = pokeArrayOff @a @lay ptr 0 + +-- | Write elements to an array, starting from the given index offset. +pokeArrayOff :: forall a lay. ( Poke a lay, Poke (Array 1 a) lay ) => Ptr a -> Int -> [a] -> IO () +pokeArrayOff ptr off vals0 + | off < 0 = pure () + | otherwise = go ( ptr `plusPtr` ( sz * off ) ) vals0 + where + sz :: Int + sz = fromIntegral $ nextAligned (sizeOf @a @lay) (alignment @(Array 1 a) @lay) + go :: Ptr a -> [a] -> IO () + go _ [] = pure () + go ptr' (val:vals) = do + poke @a @lay ptr' val + go ( ptr' `plusPtr` sz ) vals + +nextAligned :: Integral a => a -> a -> a +nextAligned size ali + = case size `mod` ali of + 0 -> size + x -> size + ali - x + +instance Poke Word8 lay where + type SizeOf lay Word8 = 4 + type Alignment lay Word8 = 4 + poke ptr = Storable.poke (castPtr @_ @Word32 ptr) . fromIntegral + +instance Poke Word16 lay where + type SizeOf lay Word16 = 4 + type Alignment lay Word16 = 4 + poke ptr = Storable.poke (castPtr @_ @Word32 ptr) . fromIntegral + +instance Poke Word32 lay where + type SizeOf lay Word32 = 4 + type Alignment lay Word32 = 4 + poke = Storable.poke + +instance Poke Word64 lay where + type SizeOf lay Word64 = 8 + type Alignment lay Word64 = 8 + poke = Storable.poke + +instance Poke Int8 lay where + type SizeOf lay Int8 = 4 + type Alignment lay Int8 = 4 + poke ptr = Storable.poke (castPtr @_ @Int32 ptr) . fromIntegral + +instance Poke Int16 lay where + type SizeOf lay Int16 = 4 + type Alignment lay Int16 = 4 + poke ptr = Storable.poke (castPtr @_ @Int32 ptr) . fromIntegral + +instance Poke Int32 lay where + type SizeOf lay Int32 = 4 + type Alignment lay Int32 = 4 + poke = Storable.poke + +instance Poke Int64 lay where + type SizeOf lay Int64 = 4 + type Alignment lay Int64 = 4 + poke = Storable.poke + +instance Poke Half lay where + type SizeOf lay Half = 4 + type Alignment lay Half = 4 + poke ptr = Storable.poke (castPtr @_ @Float ptr) . fromHalf + +instance Poke Float lay where + type SizeOf lay Float = 4 + type Alignment lay Float = 4 + poke = Storable.poke + +instance Poke Double lay where + type SizeOf lay Double = 8 + type Alignment lay Double = 8 + poke = Storable.poke + +instance TypeError ( Text "Cannot store Boolean types." ) => Poke Bool lay where + type SizeOf lay Bool = 4 + type Alignment lay Bool = 4 + poke = error "unreachable" + +-- Acceleration structures are just represented as Word64 address +instance Poke AccelerationStructure lay where + type SizeOf lay AccelerationStructure = 8 + type Alignment lay AccelerationStructure = 8 + poke ptr ( AccelerationStructureFromWord64 word64 ) = poke @Word64 @lay ( castPtr ptr ) word64 + +instance ( Poke a lay + , ScalarTy a + , KnownNat n, 1 <= n + , KnownNat (SizeOf lay (V n a)) + , KnownNat (Alignment lay (V n a)) + ) => Poke (V n a) lay where + type SizeOf lay (V n a) = n * SizeOf lay a + type Alignment lay (V n a) + = SizeOf lay a * NextPositivePowerOf2 n + poke ptr v + = foldM_ + ( \accPtr elt -> poke @a @lay accPtr elt *> pure (accPtr `plusPtr` off) ) + ( castPtr ptr ) + v + where + off :: Int + off = fromIntegral ( sizeOf @a @lay ) + +-- A matrix is laid out like an array of its columns. +-- As the size of a column is no larger than its alignment, +-- the stride between columns is the alignment of the matrix. + +instance (Poke (V m a) Base, ScalarTy a, KnownNat n, KnownNat m, 1 <= n, 1 <= m) + => Poke (M m n a) Base where + type SizeOf Base (M m n a) + = n * Alignment Base (M m n a) + type Alignment Base (M m n a) = Alignment Base (V m a) + poke ptr mat + = foldM_ + ( \accPtr col -> poke @(V m a) @Base accPtr col *> pure (accPtr `plusPtr` colStride) ) + ( castPtr ptr ) + ( unM mat ) + where + colStride = fromIntegral $ alignment @(M m n a) @Base + +instance ( Poke (V m a) Extended, ScalarTy a, KnownNat n, KnownNat m, 1 <= n, 1 <= m + , KnownNat (SizeOf Extended (M m n a)) + , KnownNat (Alignment Extended (M m n a)) + ) + => Poke (M m n a) Extended where + type SizeOf Extended (M m n a) + = n * Alignment Extended (M m n a) + type Alignment Extended (M m n a) = Alignment Extended (V m a) `RoundUp` 16 + poke ptr mat + = foldM_ + ( \accPtr col -> poke @(V m a) @Extended accPtr col *> pure (accPtr `plusPtr` colStride) ) + ( castPtr ptr ) + ( unM mat ) + where + colStride = fromIntegral $ alignment @(M m n a) @Extended + +instance ( Poke (V m a) Locations + , ScalarTy a + , KnownNat n, KnownNat m, 1 <= n, 1 <= m + , KnownNat (SizeOf Locations (M m n a)) + ) + => Poke (M m n a) Locations where + type SizeOf Locations (M m n a) + = n * ( SizeOf Locations (V m a) `RoundUp` 16 ) + type Alignment Locations (M m n a) = 16 + poke ptr mat + = foldM_ + ( \accPtr col -> poke @(V m a) @Locations accPtr col *> pure (accPtr `plusPtr` colSize) ) + ( castPtr ptr ) + ( unM mat ) + where + colSize :: Int + colSize = fromIntegral ( sizeOf @(V m a) @Locations ) `roundUp` 16 + +instance ( Poke a Base, Prim.PrimTy a, KnownNat n, 1 <= n + , KnownNat ( SizeOf Base ( Array n a ) ) + ) + => Poke (Array n a) Base where + type SizeOf Base (Array n a) = n * ( SizeOf Base a `RoundUp` Alignment Base (Array n a) ) + type Alignment Base (Array n a) = Alignment Base a + poke ptr (MkArray arr) + = foldM_ + ( \accPtr elt -> poke @a @Base accPtr elt *> pure (accPtr `plusPtr` off) ) + ( castPtr ptr ) + arr + where + off :: Int + off = fromIntegral $ nextAligned (sizeOf @a @Base) (alignment @(Array n a) @Base) + +instance ( Poke a Extended + , Prim.PrimTy a + , KnownNat n, 1 <= n + , KnownNat ( SizeOf Extended ( Array n a ) ) + , KnownNat ( Alignment Extended ( Array n a ) ) + ) + => Poke (Array n a) Extended where + type SizeOf Extended (Array n a) + = n * ( SizeOf Extended a `RoundUp` Alignment Extended (Array n a) ) + type Alignment Extended (Array n a) + = Alignment Extended a `RoundUp` 16 + poke ptr (MkArray arr) + = foldM_ + ( \accPtr elt -> poke @a @Extended accPtr elt *> pure (accPtr `plusPtr` off) ) + ( castPtr ptr ) + arr + where + off :: Int + off = fromIntegral $ nextAligned (sizeOf @a @Extended) (alignment @(Array n a) @Extended) + +instance (Poke a Locations, Prim.PrimTy a, KnownNat n, 1 <= n) + => Poke (Array n a) Locations where + type SizeOf Locations (Array n a) + = n * SizeOf Locations a + type Alignment Locations (Array n a) + = Alignment Locations a + poke ptr (MkArray arr) + = foldM_ + ( \accPtr elt -> poke @a @Locations accPtr elt *> pure (accPtr `plusPtr` off) ) + ( castPtr ptr ) + arr + where + off :: Int + off = fromIntegral $ nextAligned (sizeOf @a @Locations) (alignment @(Array n a) @Locations `roundUp` 16) + + +class ( Poke (Value x) lay ) => Pokeable (lay :: Layout) (x :: fld :-> Type) where +instance ( Poke (Value x) lay ) => Pokeable (lay :: Layout) (x :: fld :-> Type) where + +structPoke :: forall (fld :: Type) (lay :: Layout) (as :: [fld :-> Type]). + ( PrimTyMap as, All (Pokeable lay) as ) + => Word32 -> Ptr (Struct as) -> Struct as -> IO () +structPoke currOff ptr struct = case primTyMapSing @_ @as of + SNil -> pure () + scons@SCons -> case scons of + ( _ :: SPrimTyMap ((k ':-> b) ': bs) ) -> + case (struct, allDict @(Pokeable lay) @as) of + ( b :& bs, ConsDict ) -> do + let + off :: Word32 + off = nextAligned currOff ( alignment @b @lay ) + poke @b @lay ( castPtr ptr `plusPtr` ( fromIntegral off ) ) b + structPoke @fld @lay @bs ( off + sizeOf @b @lay ) ( castPtr ptr ) bs + +instance ( PrimTyMap as + , All (Pokeable Base) as + , KnownNat (SizeOf Base (Struct as)) + , KnownNat (Alignment Base (Struct as)) + ) => Poke (Struct as) Base where + type SizeOf Base (Struct as) + = SumRoundedUpSizes Base as 0 `RoundUp` Alignment Base (Struct as) + type Alignment Base (Struct as) + = MaximumAlignment Base as + poke = structPoke @_ @Base @as 0 + +instance ( PrimTyMap as + , All (Pokeable Extended) as + , KnownNat (SizeOf Extended (Struct as)) + , KnownNat (Alignment Extended (Struct as)) + ) => Poke (Struct as) Extended where + type SizeOf Extended (Struct as) + = SumRoundedUpSizes Extended as 0 `RoundUp` Alignment Extended (Struct as) + type Alignment Extended (Struct as) + = MaximumAlignment Extended as `RoundUp` 16 + poke = structPoke @_ @Extended @as 0 + +instance + ( TypeError + ( Text "Structure contains insufficient layout information." + :$$: Text "" + :$$: Text "To use the 'Locations' layout, location/component information needs to be supplied, such as:" + :$$: Text " Struct '[ Slot 0 0 ':-> V 2 Float, Slot 0 2 ':-> V 2 Float ]," + :$$: Text "where 'Slot l c' refers to the interface slot in location 'l' with component 'c'," + :$$: Text "with 0 <= l < maxVertexInputAttributes (at least 16), 0 <= c < 4." + ) + ) + => Poke (Struct (as :: [Symbol :-> Type])) Locations + where + type SizeOf Locations (Struct (as :: [Symbol :-> Type])) + = 16 + type Alignment Locations (Struct (as :: [Symbol :-> Type])) + = 16 + poke = error "unreachable" + +-- TODO: refactor this using 'Data.Constraint.All' +data PokeSlotsDict (as :: [LocationSlot Nat :-> Type]) :: Type where + NoSlotsPoke :: PokeSlotsDict '[] + PokeSlotDict :: ( Poke a Locations + , Known (LocationSlot Nat) slot + , PokeSlots as + , KnownNat (SizeOf Locations (Struct as)) + , KnownNat (Alignment Locations (Struct as)) + ) + => PokeSlotsDict ( (slot ':-> a) ': as ) + +class PokeSlots (as :: [LocationSlot Nat :-> Type]) where + pokeSlotsDict :: PokeSlotsDict as +instance PokeSlots '[] where + pokeSlotsDict = NoSlotsPoke +instance ( Poke a Locations + , Known (LocationSlot Nat) loc + , PokeSlots as + , KnownNat (SizeOf Locations (Struct as)) + , KnownNat (Alignment Locations (Struct as)) + ) + => PokeSlots ( (loc ':-> a) ': as ) + where + pokeSlotsDict = PokeSlotDict + +instance forall (as :: [LocationSlot Nat :-> Type]) + . ( PrimTyMap as + , PokeSlots as + , KnownNat (SizeOf Locations (Struct as)) + , KnownNat (Alignment Locations (Struct as)) + ) => Poke (Struct as) Locations where + type SizeOf Locations (Struct as) + = SizeOfLocations as + type Alignment Locations (Struct as) + = 16 + poke ptr struct = case primTyMapSing @_ @as of + SNil -> pure () + scons@SCons -> case scons of + ( _ :: SPrimTyMap ((loc ':-> b) ': bs) ) -> + case (struct, pokeSlotsDict @as) of + ( b :& bs, PokeSlotDict ) -> + let LocationSlot l c = knownValue @loc + off = fromIntegral $ 16 * l + 4 * c + in do + -- if we are poking another struct with location information, + -- we want to keep the pointer as is as opposed to adding an offset to it + case primTySing @b of + sStruct@SStruct + | ( _ :: SPrimTy (Struct (cs :: [fld :-> Type]) ) ) <- sStruct + , LocationField <- fieldKind @fld + -> poke @b @Locations (castPtr ptr ) b + _ -> poke @b @Locations (castPtr ptr `plusPtr` off) b + poke @(Struct bs) @Locations (castPtr ptr) bs + +type family SizeOfLocations (as :: [LocationSlot Nat :-> Type]) :: Nat where + SizeOfLocations '[] = 0 + SizeOfLocations ( ( 'LocationSlot l _ ':-> _ ) ': as ) + = Max ( 16 * (l+1) ) ( SizeOfLocations as ) + +-------------------------------------------------------------------------------------------- +-- Layout of SPIR-V types in memory. + +-- | The layout rules imposed by a storage class, if any. +storageLayoutRules :: SPIRV.StorageClass -> Maybe SPIRV.LayoutRules +storageLayoutRules Storage.Uniform = Just SPIRV.ExtendedAlignment +storageLayoutRules Storage.StorageBuffer = Just SPIRV.BaseAlignment +storageLayoutRules Storage.PushConstant = Just SPIRV.BaseAlignment +storageLayoutRules (Storage.RayStorage Storage.ShaderRecordBuffer) = Just SPIRV.BaseAlignment +storageLayoutRules _ = Nothing + +-- | The layout of a global variable of the given type, in the given storage class. +-- +-- In storage classes with explicit layout, as well as for inputs and outputs, +-- structures and arrays of structures are interface blocks. +variableLayout :: SPIRV.BlockKind -> SPIRV.StorageClass -> SPIRV.PrimTy -> SPIRV.Layout +variableLayout kind storageClass ty + = SPIRV.Layout + { SPIRV.layoutRules = rules + , SPIRV.blockKind + = if isInterface && isBlockShaped ty + then Just kind + else Nothing + } + where + rules :: Maybe SPIRV.LayoutRules + rules = storageLayoutRules storageClass + isInterface :: Bool + isInterface = isJust rules || storageClass `elem` [ Storage.Input, Storage.Output ] + isBlockShaped :: SPIRV.PrimTy -> Bool + isBlockShaped ( SPIRV.Struct {} ) = True + isBlockShaped ( SPIRV.Array _ ( SPIRV.Struct {} ) ) = True + isBlockShaped _ = False + +-- | The stride of an array with the given element type. +arrayStride :: MonadError ShortText m => SPIRV.LayoutRules -> SPIRV.PrimTy -> m Word32 +arrayStride rules eltTy = uncurry nextAligned <$> primTySizeAndAli rules ( SPIRV.Array 1 eltTy ) + +-- | The layout decorations of the members of a structure with the given member types. +memberLayoutDecorations + :: forall m + . MonadError ShortText m + => SPIRV.LayoutRules -> [ SPIRV.PrimTy ] -> m [ SPIRV.Decorations ] +memberLayoutDecorations rules = go 0 + where + go :: Word32 -> [ SPIRV.PrimTy ] -> m [ SPIRV.Decorations ] + go _ [] = pure [] + go offset ( ty : tys ) = do + ( size, ali ) <- primTySizeAndAli rules ( sizedTy ty ) + matDecs <- matrixDecorations ( innermostElement ty ) + let + memberOffset :: Word32 + memberOffset = nextAligned offset ali + ( Set.insert ( SPIRV.Offset memberOffset ) matDecs : ) <$> go ( memberOffset + size ) tys + + -- A run-time array has no size; it is laid out like an array with a single element. + sizedTy :: SPIRV.PrimTy -> SPIRV.PrimTy + sizedTy ( SPIRV.RuntimeArray { eltTy } ) = SPIRV.Array 1 eltTy + sizedTy ty = ty + + innermostElement :: SPIRV.PrimTy -> SPIRV.PrimTy + innermostElement ( SPIRV.Array { eltTy } ) = innermostElement eltTy + innermostElement ( SPIRV.RuntimeArray { eltTy } ) = innermostElement eltTy + innermostElement ty = ty + + -- The layout of a matrix is specified on the structure member that contains it; + -- a matrix is laid out like an array of its columns. + matrixDecorations :: SPIRV.PrimTy -> m SPIRV.Decorations + matrixDecorations ( SPIRV.Matrix { rows, entryTy } ) = do + colStride <- arrayStride rules ( SPIRV.Vector rows ( SPIRV.Scalar entryTy ) ) + pure ( Set.fromList [ SPIRV.MatrixStride colStride, SPIRV.ColMajor ] ) + matrixDecorations _ = pure Set.empty + +primTySizeAndAli :: MonadError ShortText m => SPIRV.LayoutRules -> SPIRV.PrimTy -> m ( Word32, Word32 ) +primTySizeAndAli SPIRV.BaseAlignment ty + | Just ( LayoutablePrimTy ( _ :: Proxy ty ) ) <- layoutable @Base ty + = pure $ ( sizeOf @ty @Base, alignment @ty @Base ) +primTySizeAndAli SPIRV.ExtendedAlignment ty + | Just ( LayoutablePrimTy ( _ :: Proxy ty ) ) <- layoutable @Extended ty + = pure $ ( sizeOf @ty @Extended, alignment @ty @Extended ) +primTySizeAndAli rules ty = throwError + ( "'primTySizeAndAli': cannot compute " <> ShortText.pack (show rules) <> " size & alignment for " <> ShortText.pack (show ty) ) + +-------------------------------------------------------------------------------------------- +-- Some functions for promoting SPIR-V primitive types that can be laid-out. +-- This allows us to re-use the type families that compute layout information +-- at the value level. + +data SLayout (lay :: Layout) where + SBase :: SLayout Base + SExtended :: SLayout Extended + SLocations :: SLayout Locations + +class KnownLayout (lay :: Layout) where + layoutSing :: SLayout lay +instance KnownLayout Base where + layoutSing = SBase +instance KnownLayout Extended where + layoutSing = SExtended +instance KnownLayout Locations where + layoutSing = SLocations + +data LayoutablePrimTy ( lay :: Layout ) where + LayoutablePrimTy :: ( Prim.PrimTy a, Poke a lay ) => Proxy a -> LayoutablePrimTy lay +data LayoutableScalarTy ( lay :: Layout ) where + LayoutableScalarTy :: ( ScalarTy a, Poke a lay ) => Proxy a -> LayoutableScalarTy lay +data LayoutableMatScalarTy ( lay :: Layout ) where + LayoutableMatScalarTy :: ( ScalarTy a, AdditiveGroup a, Semiring a, Poke a lay ) => Proxy a -> LayoutableMatScalarTy lay +data LayoutableMembers (lay :: Layout) where + LayoutableMembers + :: ( PrimTyMap as, All (Pokeable lay) as + , KnownNat (SizeOf lay (Struct as)) + , KnownNat (Alignment lay (Struct as)) + ) + => Proxy as -> LayoutableMembers lay + +layoutable :: forall ( lay :: Layout ). KnownLayout lay => SPIRV.PrimTy -> Maybe ( LayoutablePrimTy lay ) +layoutable ( SPIRV.Scalar s ) + | Just ( LayoutableScalarTy ( _ :: Proxy a ) ) <- layoutableScalar @lay s + = Just ( LayoutablePrimTy ( Proxy :: Proxy a ) ) +layoutable ( SPIRV.Vector n ( SPIRV.Scalar s ) ) + | Just ( LayoutableScalarTy ( _ :: Proxy a ) ) <- layoutableScalar @lay s + , True <- 1 <= n + , SomeNat ( _ :: Proxy n ) <- someNatVal ( fromIntegral n ) + , Refl <- ( unsafeCoerce Refl :: ( 1 <=? n ) :~: True ) + , let + npp2 :: Natural + npp2 + | n == 1 = 1 + | otherwise = 2 ^ ( floor ( logBase 2 ( realToFrac ( n - 1 ) :: Float ) ) + 1 :: Int ) + , SomeNat ( _ :: Proxy npp2 ) <- someNatVal npp2 + , Refl <- ( unsafeCoerce Refl :: NextPositivePowerOf2 n :~: npp2 ) + = Just $ LayoutablePrimTy ( Proxy :: Proxy ( V n a ) ) +layoutable ( SPIRV.Matrix m n a ) + | Just ( LayoutableMatScalarTy ( _ :: Proxy a ) ) <- layoutableMatScalar @lay a + , SomeNat ( _ :: Proxy m ) <- someNatVal ( fromIntegral m ) + , SomeNat ( _ :: Proxy n ) <- someNatVal ( fromIntegral n ) + , True <- 1 <= n + , Refl <- ( unsafeCoerce Refl :: ( 1 <=? n ) :~: True ) + , True <- 1 <= m + , Refl <- ( unsafeCoerce Refl :: ( 1 <=? m ) :~: True ) + , let + npp2 :: Natural + npp2 + | m == 1 = 1 + | otherwise = 2 ^ ( floor ( logBase 2 ( realToFrac ( m - 1 ) :: Float ) ) + 1 :: Int ) + , SomeNat ( _ :: Proxy npp2 ) <- someNatVal npp2 + , Refl <- ( unsafeCoerce Refl :: NextPositivePowerOf2 m :~: npp2 ) + = case layoutSing @lay of + SBase -> Just $ LayoutablePrimTy ( Proxy :: Proxy ( M m n a ) ) + SExtended + | let + colStride :: Word32 + colStride = alignment @(V m a) @Extended `roundUp` 16 + , SomeNat ( _ :: Proxy ali ) <- someNatVal ( fromIntegral colStride ) + , Refl <- ( unsafeCoerce Refl :: ali :~: Alignment Extended ( M m n a ) ) + , SomeNat ( _ :: Proxy sz ) <- someNatVal ( fromIntegral $ n * colStride ) + , Refl <- ( unsafeCoerce Refl :: sz :~: SizeOf Extended ( M m n a ) ) + -> Just $ LayoutablePrimTy ( Proxy :: Proxy ( M m n a ) ) + _ -> Nothing +layoutable ( SPIRV.Array { size, eltTy } ) + | Just ( LayoutablePrimTy ( _ :: Proxy a ) ) <- layoutable @lay eltTy + , True <- 1 <= size + , SomeNat ( _ :: Proxy lg ) <- someNatVal ( fromIntegral size ) + , Refl <- ( unsafeCoerce Refl :: ( 1 <=? lg ) :~: True ) + = case layoutSing @lay of + SBase + | SomeNat ( _ :: Proxy sz ) <- someNatVal ( fromIntegral $ size * ( nextAligned ( sizeOf @a @Base ) ( alignment @a @Base ) ) ) + , Refl <- ( unsafeCoerce Refl :: sz :~: SizeOf Base ( Array lg a ) ) + -> Just $ LayoutablePrimTy ( Proxy :: Proxy ( Array lg a ) ) + SExtended + | SomeNat ( _ :: Proxy sz ) <- someNatVal ( fromIntegral $ size * ( nextAligned ( sizeOf @a @Extended ) ( alignment @a @Extended `roundUp` 16 ) ) ) + , Refl <- ( unsafeCoerce Refl :: sz :~: SizeOf Extended ( Array lg a ) ) + , SomeNat ( _ :: Proxy ali ) <- someNatVal ( fromIntegral $ alignment @a @Extended `roundUp` 16 ) + , Refl <- ( unsafeCoerce Refl :: ali :~: (Alignment Extended a `RoundUp` 16) ) + -> Just $ LayoutablePrimTy ( Proxy :: Proxy ( Array lg a ) ) + _ -> Nothing +layoutable ( SPIRV.Struct { eltTys } ) = layoutableStruct @lay eltTys +layoutable _ = Nothing + +layoutableScalar :: forall ( lay :: Layout ). SPIRV.ScalarTy -> Maybe ( LayoutableScalarTy lay ) +layoutableScalar ( SPIRV.Integer SPIRV.Unsigned SPIRV.W8 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Word8 ) +layoutableScalar ( SPIRV.Integer SPIRV.Unsigned SPIRV.W16 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Word16 ) +layoutableScalar ( SPIRV.Integer SPIRV.Unsigned SPIRV.W32 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Word32 ) +layoutableScalar ( SPIRV.Integer SPIRV.Unsigned SPIRV.W64 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Word64 ) +layoutableScalar ( SPIRV.Integer SPIRV.Signed SPIRV.W8 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Int8 ) +layoutableScalar ( SPIRV.Integer SPIRV.Signed SPIRV.W16 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Int16 ) +layoutableScalar ( SPIRV.Integer SPIRV.Signed SPIRV.W32 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Int32 ) +layoutableScalar ( SPIRV.Integer SPIRV.Signed SPIRV.W64 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Int64 ) +layoutableScalar ( SPIRV.Floating SPIRV.W16 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Half ) +layoutableScalar ( SPIRV.Floating SPIRV.W32 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Float ) +layoutableScalar ( SPIRV.Floating SPIRV.W64 ) = Just $ LayoutableScalarTy ( Proxy :: Proxy Double ) +layoutableScalar _ = Nothing + +layoutableMatScalar :: forall ( lay :: Layout ). SPIRV.ScalarTy -> Maybe ( LayoutableMatScalarTy lay ) +layoutableMatScalar ( SPIRV.Integer SPIRV.Signed SPIRV.W8 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Int8 ) +layoutableMatScalar ( SPIRV.Integer SPIRV.Signed SPIRV.W16 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Int16 ) +layoutableMatScalar ( SPIRV.Integer SPIRV.Signed SPIRV.W32 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Int32 ) +layoutableMatScalar ( SPIRV.Integer SPIRV.Signed SPIRV.W64 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Int64 ) +layoutableMatScalar ( SPIRV.Floating SPIRV.W16 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Half ) +layoutableMatScalar ( SPIRV.Floating SPIRV.W32 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Float ) +layoutableMatScalar ( SPIRV.Floating SPIRV.W64 ) = Just $ LayoutableMatScalarTy ( Proxy :: Proxy Double ) +layoutableMatScalar _ = Nothing + +layoutableStruct + :: forall ( lay :: Layout ) mbName + . KnownLayout lay + => [ ( mbName, SPIRV.PrimTy ) ] + -> Maybe ( LayoutablePrimTy lay ) +layoutableStruct elts = makeLayoutableStruct =<< layoutableStructMembers 0 elts + where + layoutableStructMembers :: Int -> [ ( mbName, SPIRV.PrimTy ) ] -> Maybe [ ( SomeSymbol, LayoutablePrimTy lay ) ] + layoutableStructMembers _ [] = Just [] + layoutableStructMembers i ( (_,ty) : tys ) + | Just layoutableTy <- layoutable @lay ty + , Just layoutableTys <- layoutableStructMembers (i+1) tys + , nm <- someSymbolVal ( show i ) + = Just ( ( nm, layoutableTy ) : layoutableTys ) + layoutableStructMembers _ _ = Nothing + + makeLayoutableStruct :: [ ( SomeSymbol, LayoutablePrimTy lay ) ] -> Maybe ( LayoutablePrimTy lay ) + makeLayoutableStruct members + | Just ( LayoutableMembers ( _ :: Proxy as ) ) <- makeLayoutableMembers members + = case layoutSing @lay of + SBase -> Just ( LayoutablePrimTy ( Proxy :: Proxy ( Struct as ) ) ) + SExtended -> Just ( LayoutablePrimTy ( Proxy :: Proxy ( Struct as ) ) ) + _ -> Nothing + makeLayoutableStruct _ = Nothing + + makeLayoutableMembers :: [ ( SomeSymbol, LayoutablePrimTy lay ) ] -> Maybe ( LayoutableMembers lay ) + makeLayoutableMembers [] = case layoutSing @lay of + SBase -> Just ( LayoutableMembers ( Proxy :: Proxy ('[] :: [ Symbol :-> Type ] ) ) ) + SExtended -> Just ( LayoutableMembers ( Proxy :: Proxy ('[] :: [ Symbol :-> Type ] ) ) ) + _ -> Nothing + makeLayoutableMembers members@( ( SomeSymbol ( _ :: Proxy nm ), LayoutablePrimTy ( _ :: Proxy a ) ) : as ) + | Just ( LayoutableMembers ( _ :: Proxy ( as :: [ fld :-> Type ] ) ) ) <- makeLayoutableMembers as + , NamedField <- fieldKind @fld + , ( structSize, structAli ) <- structSizeAndAlignment @lay members + , SomeNat ( _ :: Proxy structSize ) <- someNatVal ( fromIntegral structSize ) + , Refl <- ( unsafeCoerce Refl :: structSize :~: SizeOf lay ( Struct ( ( nm ':-> a ) ': as ) ) ) + , SomeNat ( _ :: Proxy structAli ) <- someNatVal ( fromIntegral structAli ) + , Refl <- ( unsafeCoerce Refl :: structAli :~: Alignment lay ( Struct ( ( nm ':-> a ) ': as ) ) ) + = case layoutSing @lay of + SBase -> Just ( LayoutableMembers ( Proxy :: Proxy ( ( nm ':-> a ) ': as ) ) ) + SExtended -> Just ( LayoutableMembers ( Proxy :: Proxy ( ( nm ':-> a ) ': as ) ) ) + _ -> Nothing + makeLayoutableMembers _ = Nothing + +-- | Size and alignment of a structure with the given members. +-- +-- The size of a structure is rounded up to its alignment. +structSizeAndAlignment + :: forall ( lay :: Layout ) + . KnownLayout lay + => [ ( SomeSymbol, LayoutablePrimTy lay ) ] -> ( Word32, Word32 ) +structSizeAndAlignment members = ( nextAligned ( foldl' memberEnd 0 members ) structAli, structAli ) + where + structAli :: Word32 + structAli = case layoutSing @lay of + SExtended -> maxAli `roundUp` 16 + _ -> maxAli + maxAli :: Word32 + maxAli = maximum ( 1 : map memberAlignment members ) + memberAlignment :: ( SomeSymbol, LayoutablePrimTy lay ) -> Word32 + memberAlignment ( _, LayoutablePrimTy ( _ :: Proxy b ) ) = alignment @b @lay + memberEnd :: Word32 -> ( SomeSymbol, LayoutablePrimTy lay ) -> Word32 + memberEnd offset ( _, LayoutablePrimTy ( _ :: Proxy b ) ) = nextAligned offset ( alignment @b @lay ) + sizeOf @b @lay diff --git a/src/FIR/Module.hs b/src/FIR/Module.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Module.hs @@ -0,0 +1,117 @@ +{-# OPTIONS_HADDOCK ignore-exports #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Module + +Utility wrapper types for programs. + +A program essentially consists of a value of type @Codensity AST (AST a := j) i@, +but with additional type-level information pertaining to the program inputs/outputs, +similar to the interface for a shader module in @OpenGL@ or @Vulkan@. + +See "FIR.ProgramState" which defines the type-level data that programs keep track of. +-} + +module FIR.Module + ( Program + , Module(Module) + , ShaderModule(ShaderModule) + ) + where + +-- base +import Data.Kind + ( Type ) +import GHC.TypeLits + ( Symbol ) + +-- fir +import Control.Monad.Indexed + ( (:=)(AtKey), Codensity(..) ) +import Data.Type.Map + ( (:->) ) +import FIR.AST + ( AST, Code + , Syntactic(..), SyntacticVal, InternalType + , pattern (:$), pattern Bind, pattern Return + ) +import FIR.AST.Type + ( Eff ) +import FIR.Definition + ( Definition, KnownDefinitions + , StartState + ) +import FIR.ProgramState + ( ProgramState ) +import FIR.Validation.Definitions + ( ValidDefinitions ) +import qualified SPIRV.Stage as SPIRV + ( Shader ) + +-------------------------------------------------------------------------- +-- * Program type synonym +-- +-- $wrappers +-- Wrapper for the main internal representation +-- @Codensity AST (a := j) i@ + +type Program (i :: ProgramState) (j :: ProgramState) (a :: Type) + = Codensity AST (a := j) i + +instance SyntacticVal a => Syntactic (Program i j a) where + type Internal (Codensity AST (a := j) i) = Eff i j (InternalType a) + + toAST :: Codensity AST (a := j) i -> AST ( Eff i j (InternalType a) ) + toAST (Codensity k) = k ( \(AtKey a) -> Return :$ toAST a ) + + fromAST :: AST ( Eff i j (InternalType a) ) -> Codensity AST (a := j) i + fromAST a = Codensity ( \k -> Bind :$ toAST a :$ toAST (k . AtKey) ) + +-------------------------------------------------------------------------- +-- * Module type + +-- | A 'Module' wraps a value-level program with additional +-- 'Definition's which specify the interface of the module, +-- such as memory layout of input and output data. +-- +-- Corresponds to the concept of a SPIR-V module. +data Module + ( defs :: [ Symbol :-> Definition ] ) + :: Type where + Module :: forall defs endState + . ( KnownDefinitions defs, ValidDefinitions defs ) + => Program (StartState defs) endState (Code ()) + -> Module defs + +-------------------------------------------------------------------------- +-- * Shader stage type + +-- | Value-level wrapper for a shader stage. +-- +-- Takes a module (which may have multiple shaders defined), +-- and specifies (using name + stage) which shader +-- is being referred to (e.g. for use in a shader pipeline). +-- +-- Keeps track of the final indexed monadic state of the shader, +-- which is used to perform type-level validation. +data ShaderModule + ( name :: Symbol ) + ( stage :: SPIRV.Shader ) + ( defs :: [Symbol :-> Definition] ) + ( endState :: ProgramState ) + where + ShaderModule + :: forall name stage defs endState + . ( KnownDefinitions defs, ValidDefinitions defs ) + => Program (StartState defs) endState (Code ()) + -> ShaderModule name stage defs endState diff --git a/src/FIR/Pipeline.hs b/src/FIR/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Pipeline.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Pipeline + +This module encodes the Vulkan concept of graphics pipelines +as a sequence of shader programs. + +See "FIR.Validation.Pipeline" for the validation of such pipelines. +-} + +module FIR.Pipeline + ( PipelineInfo(..) + , PipelineStages(..), pipelineStages + , ShaderPipeline(..), pipelineShaders + , ShaderGroup(..) + , PrimitiveConnectedness(..) + , PrimitiveTopology(..) + , BindingStrides + , VertexLocationDescriptions + , GetVertexInputInfo, GetTopologyInfo -- (re-exports) + ) + where + +-- base +import Data.Kind + ( Type ) +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( Symbol ) +import GHC.TypeNats + ( Nat, KnownNat ) + +-- fir +import Data.Type.Known + ( Demotable(Demote), Known(known), knownValue ) +import Data.Type.Map + ( (:->) ) +import FIR.Definition + ( Variables ) +import FIR.Module + ( ShaderModule ) +import FIR.ProgramState + ( Definedness(Defined) + , EntryPointInfo(EntryPointInfo) + ) +import FIR.Validation.Pipeline + ( ValidPipelineInfo + , GetExecutionInfo + , GetVertexInputInfo + , GetTopologyInfo + ) +import qualified SPIRV.Image as SPIRV + ( ImageFormat ) +import qualified SPIRV.Stage as SPIRV + +-------------------------------------------------------------------------- +-- * Primitive topologies + +data PrimitiveConnectedness + = List + | Strip + | Fan + | AdjacencyList + | AdjacencyStrip + deriving stock ( Eq, Ord, Show, Enum, Bounded ) + +data PrimitiveTopology (n :: Type) + = Points + | Line PrimitiveConnectedness + | Triangle PrimitiveConnectedness + | PatchesOfSize n + deriving stock ( Eq, Show ) + +instance Demotable PrimitiveConnectedness where + type Demote PrimitiveConnectedness = PrimitiveConnectedness + +instance Known PrimitiveConnectedness 'List where + known = List +instance Known PrimitiveConnectedness 'Strip where + known = Strip +instance Known PrimitiveConnectedness 'Fan where + known = Fan +instance Known PrimitiveConnectedness 'AdjacencyList where + known = AdjacencyList +instance Known PrimitiveConnectedness 'AdjacencyStrip where + known = AdjacencyStrip + +instance Demotable (PrimitiveTopology Nat) where + type Demote (PrimitiveTopology Nat) = PrimitiveTopology Word32 + +instance Known (PrimitiveTopology Nat) 'Points where + known = Points +instance Known PrimitiveConnectedness conn + => Known (PrimitiveTopology Nat) ('Line conn) where + known = Line ( knownValue @conn ) +instance Known PrimitiveConnectedness conn + => Known (PrimitiveTopology Nat) ('Triangle conn) where + known = Triangle ( knownValue @conn ) +instance KnownNat n => Known (PrimitiveTopology Nat) ('PatchesOfSize n) where + known = PatchesOfSize ( knownValue @n ) + +------------------------------------------------------- +-- * Graphics pipelines + +-- | For each location: +-- - a binding index, +-- - the offset (in bytes) within the buffer bound at that index, +-- - the image format of the location. +type VertexLocationDescriptions = [ Nat :-> ( Nat, Nat, SPIRV.ImageFormat Nat ) ] + +-- | For each binding, the corresponding stride to use. +type BindingStrides = [ Nat :-> Nat ] + +-- | Pipeline information data kind. +-- +-- Records information about a pipeline which should be kept track of at the type level, +-- to be used for validation. +-- +-- - Primitive topology used for the pipeline, +-- - layout information (vertex location descriptions, binding strides), +-- - type-level information associated to each shader in the pipeline, +-- such as the type of shader (vertex shader, geometry shader, ...) +-- and the input/output interfaces (for interface matching). +-- +-- Represented as a snoc-list, beginning with vertex input information, +-- and then the sequence of shaders in order. +data PipelineInfo where + VertexInputInfo + :: PrimitiveTopology Nat + -> VertexLocationDescriptions + -> BindingStrides + -> PipelineInfo + Into + :: PipelineInfo + -> ( Symbol, EntryPointInfo ) + -> PipelineInfo + +-- | Value-level sequence of pipeline stages. +-- +-- Specified as a snoc-list: +-- +-- > VertexInput @top @descs @strides :>-> (shader_1, filepath_1) :>-> ... (shader_n, filepath_n) +-- +-- Keeps track of type-level information necessary for validation. +data PipelineStages (info :: PipelineInfo) (stageData :: Type) where + VertexInput + :: forall + ( top :: PrimitiveTopology Nat ) + ( descs :: VertexLocationDescriptions ) + ( strides :: BindingStrides ) + ( stageData :: Type ) + . ( Known (PrimitiveTopology Nat) top + , Known VertexLocationDescriptions descs + , Known BindingStrides strides + ) + => PipelineStages (VertexInputInfo top descs strides) stageData + (:>->) :: ( Known SPIRV.Shader shader ) + => PipelineStages info stageData + -> ( ShaderModule name shader defs endState, stageData ) + -> PipelineStages + ( info `Into` + '( name + , 'EntryPointInfo + ( GetExecutionInfo shader name endState ) + ( Variables defs ) + 'Defined + ) + ) + stageData + +deriving stock instance Functor (PipelineStages info) +deriving stock instance Foldable (PipelineStages info) +deriving stock instance Traversable (PipelineStages info) + +-- | Smart wrapper for a shader pipeline, +-- performing type-level validation on a sequence of pipeline stages. +data ShaderPipeline (stageData :: Type) where + ShaderPipeline + :: forall + ( info :: PipelineInfo ) + ( top :: PrimitiveTopology Nat ) + ( descs :: VertexLocationDescriptions ) + ( strides :: BindingStrides ) + ( stageData :: Type ) + . ( ValidPipelineInfo info + , '(top, descs, strides) ~ GetVertexInputInfo info + , Known (PrimitiveTopology Nat) top + , Known VertexLocationDescriptions descs + , Known BindingStrides strides + ) + => PipelineStages info stageData + -> ShaderPipeline stageData + +deriving stock instance Functor ShaderPipeline +deriving stock instance Foldable ShaderPipeline +deriving stock instance Traversable ShaderPipeline + +pipelineStages :: PipelineStages info stageData -> [(SPIRV.Shader, stageData)] +pipelineStages = reverse . go [] + where + go :: [(SPIRV.Shader, stageData)] -> PipelineStages info2 stageData -> [(SPIRV.Shader, stageData)] + go shaders VertexInput = shaders + go shaders ( info :>-> ( (_ :: ShaderModule name shader defs endState) , stageData) ) + = go ( (knownValue @shader, stageData) : shaders) info + +pipelineShaders :: ShaderPipeline stageData -> [(SPIRV.Shader, stageData)] +pipelineShaders (ShaderPipeline stages) = pipelineStages stages + +-------------------------------------------------------------------------- +-- * Ray-tracing shader groups + +-- | Utility datatype used to organise ray-tracing shaders into groups, +-- to facilitate creation of a Vulkan ray-tracing pipeline. +data ShaderGroup a + = RaygenGroup a + | MissGroup a + | CallableGroup a + | HitGroup + { intersection :: Maybe a + , closestHit :: Maybe a + , anyHit :: Maybe a + } + deriving stock ( Show, Eq, Functor, Foldable, Traversable ) diff --git a/src/FIR/Pipeline.hs-boot b/src/FIR/Pipeline.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/Pipeline.hs-boot @@ -0,0 +1,66 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module FIR.Pipeline + ( PipelineInfo(..) + , PrimitiveConnectedness(..) + , PrimitiveTopology(..) + , VertexLocationDescriptions + , BindingStrides + ) + where + +-- base +import Data.Kind + ( Type ) +import GHC.TypeLits + ( Symbol ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.Map + ( (:->) ) +import FIR.ProgramState + ( EntryPointInfo ) +import qualified SPIRV.Image as SPIRV + +-------------------------------------------------------------------------- + +data PrimitiveConnectedness + = List + | Strip + | Fan + | AdjacencyList + | AdjacencyStrip + +data PrimitiveTopology (n :: Type) + = Points + | Line PrimitiveConnectedness + | Triangle PrimitiveConnectedness + | PatchesOfSize n + +type VertexLocationDescriptions = [ Nat :-> ( Nat, Nat, SPIRV.ImageFormat Nat ) ] + +type BindingStrides = [ Nat :-> Nat ] + +data PipelineInfo where + VertexInputInfo + :: PrimitiveTopology Nat + -> VertexLocationDescriptions + -> BindingStrides + -> PipelineInfo + Into + :: PipelineInfo + -> ( Symbol, EntryPointInfo ) + -> PipelineInfo diff --git a/src/FIR/Prelude.hs b/src/FIR/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Prelude.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} + +-- | An internal module which re-exports some definitions needed +-- from the Prelude and related modules. +-- +-- As a user of the EDSL, you should never need to import this module. +module FIR.Prelude + ( module Prelude + , module Data.Int + , module Data.Word + , module Numeric.Half + , module Data.Complex + , module Data.Coerce + , module Data.String + , module Data.Kind + ) + where + +import Prelude + ( Bool(..), Maybe(..), Either(..) + , Float, Double + , Semigroup(..), Monoid(..) + , IO + , FilePath +#if __GLASGOW_HASKELL__ >= 903 + , type (~) +#endif + , ($), (.) + , otherwise, maybe, either + , fst, snd + , curry, uncurry + , subtract + , id, const + , flip + , until, asTypeOf + , error, errorWithoutStackTrace + , seq, ($!) + ) + +-- NB: deliberately not re-exporting Int/Word. +import Data.Int + ( Int8, Int16, Int32, Int64 ) +import Data.Word + ( Word8, Word16, Word32, Word64 ) +import Numeric.Half + ( Half ) + +import Data.Complex + ( Complex(..) ) + +import Data.Coerce + ( Coercible, coerce ) + +import Data.String + ( IsString(..) ) + +import Data.Kind + ( Type, Constraint ) diff --git a/src/FIR/Prim/Array.hs b/src/FIR/Prim/Array.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Prim/Array.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Prim.Array + +This module defines the array type used in this library, +which simply consists in a wrapper around a 'Data.Vector.Vector'. + +There are two kinds of arrays: + + * arrays, affixed with a type-level natural number denoting their length, + * runtime arrays, whose length is not statically known. + +The user cannot create new runtime arrays within a SPIR-V module +(although this is not currently enforced by this library), +as they are only meant to be used as inputs within shader storage buffer objects, +as the last object within a 'FIR.Synonyms.StorageBuffer'. +-} + +module FIR.Prim.Array + ( Array(..) + , RuntimeArray(..) + ) + where + +-- base +import Data.Coerce + ( coerce ) +import Data.Kind + ( Type ) +import GHC.TypeNats + ( Nat, KnownNat, type (+) ) + +-- vector +import qualified Data.Vector as Unsized + ( Vector ) + +-- vector-sized +import qualified Data.Vector.Sized as V + ( Vector, (++) ) + +-- fir +import Math.Algebra.GradedSemigroup + ( GradedSemigroup(..) ) + +------------------------------------------------------------ +-- arrays + +newtype Array :: Nat -> Type -> Type where + MkArray :: V.Vector n a -> Array n a + +deriving stock instance Eq a => Eq (Array n a) +deriving stock instance Ord a => Ord (Array n a) +deriving stock instance Show a => Show (Array n a) +deriving via (V.Vector n) instance Functor (Array n) +deriving via (V.Vector n) instance Foldable (Array n) +deriving stock instance Traversable (Array n) +deriving via (V.Vector n) instance KnownNat n => Applicative (Array n) + +instance GradedSemigroup (Array 0 a) Nat where + type Grade Nat (Array 0 a) l = Array l a + type l1 :: l2 = l1 + l2 + () = coerce (V.++) + +newtype RuntimeArray (a :: Type) = MkRuntimeArray (Unsized.Vector a) + +deriving via Unsized.Vector a instance Eq a => Eq (RuntimeArray a) +deriving via Unsized.Vector a instance Ord a => Ord (RuntimeArray a) +deriving via Unsized.Vector a instance Show a => Show (RuntimeArray a) +deriving via Unsized.Vector instance Functor RuntimeArray +deriving via Unsized.Vector instance Foldable RuntimeArray +deriving stock instance Traversable RuntimeArray diff --git a/src/FIR/Prim/Atomic.hs b/src/FIR/Prim/Atomic.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Prim/Atomic.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Prim.Atomic + +Atomic operations (loads, stores, exchanges, and arithmetic and bitwise +read-modify-write operations), and the scalar types that support them. +-} + +module FIR.Prim.Atomic + ( AtomicOp(..), SAtomicOp(..), atomicOp + , AtomicShape(..), SAtomicShape(..), AtomicOpShape, atomicShape + , AtomicTy, AtomicIntegralTy, AtomicOpTy + ) + where + +-- base +import Data.Int + ( Int32, Int64 ) +import Data.Kind + ( Type, Constraint ) +import Data.Word + ( Word32, Word64 ) + +-- half +import Numeric.Half + ( Half ) + +-- fir +import FIR.Prim.Types + ( ScalarTy, IntegralTy ) + +------------------------------------------------------------ + +-- | Atomic operations on the scalar a pointer points to. +data AtomicOp + = AtomicLoad -- ^ Read the value. + | AtomicStore -- ^ Write a value. + | AtomicExchange -- ^ Write a value, returning the previous value. + | AtomicCompareExchange -- ^ Write a value if the current value equals + -- an expected value. + | AtomicIncrement -- ^ Add one. + | AtomicDecrement -- ^ Subtract one. + | AtomicAdd -- ^ Add a value. + | AtomicSub -- ^ Subtract a value. + | AtomicMin -- ^ Take the minimum with a value. + | AtomicMax -- ^ Take the maximum with a value. + | AtomicAnd -- ^ Bitwise and with a value. + | AtomicOr -- ^ Bitwise or with a value. + | AtomicXor -- ^ Bitwise exclusive or with a value. + deriving stock ( Eq, Show ) + +-- | Singleton for 'AtomicOp'. +data SAtomicOp ( op :: AtomicOp ) where + SAtomicLoad :: SAtomicOp 'AtomicLoad + SAtomicStore :: SAtomicOp 'AtomicStore + SAtomicExchange :: SAtomicOp 'AtomicExchange + SAtomicCompareExchange :: SAtomicOp 'AtomicCompareExchange + SAtomicIncrement :: SAtomicOp 'AtomicIncrement + SAtomicDecrement :: SAtomicOp 'AtomicDecrement + SAtomicAdd :: SAtomicOp 'AtomicAdd + SAtomicSub :: SAtomicOp 'AtomicSub + SAtomicMin :: SAtomicOp 'AtomicMin + SAtomicMax :: SAtomicOp 'AtomicMax + SAtomicAnd :: SAtomicOp 'AtomicAnd + SAtomicOr :: SAtomicOp 'AtomicOr + SAtomicXor :: SAtomicOp 'AtomicXor + +atomicOp :: SAtomicOp op -> AtomicOp +atomicOp SAtomicLoad = AtomicLoad +atomicOp SAtomicStore = AtomicStore +atomicOp SAtomicExchange = AtomicExchange +atomicOp SAtomicCompareExchange = AtomicCompareExchange +atomicOp SAtomicIncrement = AtomicIncrement +atomicOp SAtomicDecrement = AtomicDecrement +atomicOp SAtomicAdd = AtomicAdd +atomicOp SAtomicSub = AtomicSub +atomicOp SAtomicMin = AtomicMin +atomicOp SAtomicMax = AtomicMax +atomicOp SAtomicAnd = AtomicAnd +atomicOp SAtomicOr = AtomicOr +atomicOp SAtomicXor = AtomicXor + +-- | The shape of an atomic operation: its operands besides the pointer, +-- and its result. +data AtomicShape + = Reads -- ^ No operand; returns the value. + | Writes -- ^ One operand; returns nothing. + | Modifies -- ^ One operand; returns the previous value. + | Compares -- ^ Two operands (the expected value, then the new value); + -- returns the previous value. + +-- | Singleton for 'AtomicShape'. +data SAtomicShape ( sh :: AtomicShape ) where + SReads :: SAtomicShape 'Reads + SWrites :: SAtomicShape 'Writes + SModifies :: SAtomicShape 'Modifies + SCompares :: SAtomicShape 'Compares + +type AtomicOpShape :: AtomicOp -> AtomicShape +type family AtomicOpShape op where + AtomicOpShape 'AtomicLoad = 'Reads + AtomicOpShape 'AtomicIncrement = 'Reads + AtomicOpShape 'AtomicDecrement = 'Reads + AtomicOpShape 'AtomicStore = 'Writes + AtomicOpShape 'AtomicCompareExchange = 'Compares + AtomicOpShape _ = 'Modifies + +atomicShape :: SAtomicOp op -> SAtomicShape ( AtomicOpShape op ) +atomicShape SAtomicLoad = SReads +atomicShape SAtomicIncrement = SReads +atomicShape SAtomicDecrement = SReads +atomicShape SAtomicStore = SWrites +atomicShape SAtomicCompareExchange = SCompares +atomicShape SAtomicExchange = SModifies +atomicShape SAtomicAdd = SModifies +atomicShape SAtomicSub = SModifies +atomicShape SAtomicMin = SModifies +atomicShape SAtomicMax = SModifies +atomicShape SAtomicAnd = SModifies +atomicShape SAtomicOr = SModifies +atomicShape SAtomicXor = SModifies + +-- | Scalar types on which atomic operations are supported: +-- 32-bit and 64-bit integers, and floating-point numbers. +-- +-- Under Vulkan, 64-bit integer atomics require the @shaderBufferInt64Atomics@ +-- or @shaderSharedInt64Atomics@ features, and floating-point atomics require +-- features of @VK_EXT_shader_atomic_float@ (and of @VK_EXT_shader_atomic_float2@ +-- for 16-bit floating-point numbers, and for minimum and maximum). +class ScalarTy ty => AtomicTy ty +instance AtomicTy Word32 +instance AtomicTy Word64 +instance AtomicTy Int32 +instance AtomicTy Int64 +instance AtomicTy Half +instance AtomicTy Float +instance AtomicTy Double + +-- | Integral types on which atomic operations are supported: +-- 32-bit and 64-bit integers. +class ( AtomicTy ty, IntegralTy ty ) => AtomicIntegralTy ty +instance AtomicIntegralTy Word32 +instance AtomicIntegralTy Word64 +instance AtomicIntegralTy Int32 +instance AtomicIntegralTy Int64 + +-- | Scalar types on which a given atomic operation is supported: bitwise +-- operations, subtraction, increment, decrement and compare-exchange are only +-- supported on integers. +type AtomicOpTy :: AtomicOp -> Type -> Constraint +type family AtomicOpTy op ty where + AtomicOpTy 'AtomicCompareExchange ty = AtomicIntegralTy ty + AtomicOpTy 'AtomicIncrement ty = AtomicIntegralTy ty + AtomicOpTy 'AtomicDecrement ty = AtomicIntegralTy ty + AtomicOpTy 'AtomicSub ty = AtomicIntegralTy ty + AtomicOpTy 'AtomicAnd ty = AtomicIntegralTy ty + AtomicOpTy 'AtomicOr ty = AtomicIntegralTy ty + AtomicOpTy 'AtomicXor ty = AtomicIntegralTy ty + AtomicOpTy _ ty = AtomicTy ty diff --git a/src/FIR/Prim/Image.hs b/src/FIR/Prim/Image.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Prim/Image.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Prim.Image + +This module defines the 'Image' datatype, +which is a void datatype used to manipulate image handles. + +This datatype is annotated at the type-level with various properties +describing the image, such as the format of the image (e.g. RGBA8, depth image, etc). +-} + +module FIR.Prim.Image + ( -- * Images + -- ** Image properties + ImageCoordinateKind(..) + , ImageProperties(Properties) + -- ** Opaque image data type + , Image + -- ** Type reflection of image properties + -- $reflection + , ImageAndCoordinate(..) + , knownImage, knownImageCoordinateKind + + -- * Image operands + , OperandName(..), ImageOperands + -- ** Specific data type for gathering operations + , Gather(..), GatherInfo(..) + + -- * Helper type families for checking validity of image operands + , CanAddProj, CanAddDref, BasicDim, NotCubeDim + , NoMS, NoDuplicate, CanMultiSample + , NoLODOps, UsesAffineCoords + , WhichGather + ) + where + +-- base +import Data.Int + ( Int32 ) +import Data.Kind + ( Type ) +import Data.Type.Bool + ( If ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.Known + ( Demotable(Demote), Known(known), knownValue ) +import Data.Type.List + ( Elem ) +import FIR.Prim.Array + ( Array ) +import {-# SOURCE #-} FIR.Prim.Types + ( ScalarTy, scalarTy ) +import FIR.Validation.Images + ( MatchesFormat, BasicDim, NotCubeDim + , CanAddProj, CanAddDref + , UsesAffineCoords + , NoDuplicate + , NoMS, CanMultiSample + , NoLODOps + ) +import Math.Linear + ( V ) +import SPIRV.Image + ( Arrayness(..) + , Dimensionality(..) + , HasDepth(..) + , ImageUsage(..) + , ImageFormat(..) + , MultiSampling(..) + , Operand + ) +import qualified SPIRV.Image as SPIRV + ( Image(..) ) + +-------------------------------------------------- + +-- | Properties of an image, used as a data kind +-- to describe the properties of an image at the type-level. +-- +-- This allows type-checking that the image properties +-- comply with the @SPIR-V@ specification, as well +-- as check that operations done with the image are valid. +data ImageProperties where + Properties + :: ImageCoordinateKind -- ^ The kind of coordinates this image allows (integral/floating point). + -> Type -- ^ Texel component type. + -> Dimensionality -- ^ Dimensionality of the image (1D, 2D, 3D, cubemap, ...). + -> Maybe HasDepth -- ^ Whether the image is a depth image. + -> Arrayness -- ^ Whether the image has an extra array component. + -> MultiSampling -- ^ Whether the image is multisampled. + -> ImageUsage -- ^ Is the image sampled or a storage image? + -> Maybe (ImageFormat Nat) -- ^ 'SPIRV.Image.ImageFormat' of the image. + -> ImageProperties + +-- | The kind of coordinates that an image format supports. +data ImageCoordinateKind + = IntegralCoordinates -- ^ Access image texels using integral coordinates. + | FloatingPointCoordinates -- ^ Access image texels using floating point coordinates. + +instance Demotable ImageCoordinateKind where + type Demote ImageCoordinateKind = ImageCoordinateKind +instance Known ImageCoordinateKind IntegralCoordinates where + known = IntegralCoordinates +instance Known ImageCoordinateKind FloatingPointCoordinates where + known = FloatingPointCoordinates + +-- | Abstract handle to an image. +data Image (props :: ImageProperties) + +-- newtype to retain injectivity of 'Demote' type family +newtype ImageAndCoordinate + = ImageAndCoordinate (SPIRV.Image, ImageCoordinateKind) + +instance Demotable ImageProperties where + type Demote ImageProperties = ImageAndCoordinate + +instance ( Known ImageCoordinateKind coordKind + , ScalarTy texelComp + , Known Dimensionality dimensionality + , Known (Maybe HasDepth) hasDepth + , Known Arrayness arrayness + , Known MultiSampling multiSampling + , Known ImageUsage imageUsage + , Known (Maybe (ImageFormat Nat)) imageFormat + , MatchesFormat imageFormat texelComp + ) + => Known ImageProperties + ( 'Properties + coordKind texelComp + dimensionality hasDepth + arrayness multiSampling + imageUsage imageFormat + ) + where + known + = ImageAndCoordinate + ( SPIRV.Image + { SPIRV.texelComponent = scalarTy @texelComp + , SPIRV.dimensionality = knownValue @dimensionality + , SPIRV.hasDepth = knownValue @hasDepth + , SPIRV.arrayness = knownValue @arrayness + , SPIRV.multiSampling = knownValue @multiSampling + , SPIRV.imageUsage = Just (knownValue @imageUsage) + , SPIRV.imageFormat = knownValue @imageFormat + } + , knownValue @coordKind + ) + + +-- $reflection +-- +-- As image properties are provided at the type level, +-- we use the 'Data.Type.Known.Known' mechanism to reflect +-- this type-level information to the value level. + +-- | Provided image properties at the type-level, +-- return the kind of coordinates that the image uses. +knownImageCoordinateKind + :: forall props. Known ImageProperties props + => ImageCoordinateKind +knownImageCoordinateKind + = case knownValue @props of + ImageAndCoordinate (_, coordKind) -> coordKind + +-- | Return the 'SPIRV.Image.Image' type with the given properties. +knownImage :: forall props. Known ImageProperties props => SPIRV.Image +knownImage + = case knownValue @props of + ImageAndCoordinate (img, _) -> img + +-------------------------------------------------- +-- Image operands + +-- | Names of image operands. +-- +-- These are used to keep track at the type level of the operands +-- which have been provided. +-- +-- This is necessary so that we can type check their usage, +-- and know which types are being used in conjunction with the image. +-- +-- For instance, if a depth-comparison is being performed, +-- the return of an image sampling operation is a scalar, +-- whereas otherwise it is a 4-vector. +data OperandName + = DepthComparison -- ^ Whether a depth-comparison is being performed. + | ProjectiveCoords -- ^ Whether to use projective coordinates. + | BaseOperand SPIRV.Image.Operand -- A @SPIR-V@ image "SPIRV.Image.Operand". + deriving stock ( Show, Eq, Ord ) + +-- | == Image operands. +-- +-- As there is no support for images in the evaluator, this datatype holds no information. +-- +-- However, values of type @Code (ImageOperands props ops)@ +-- can be constructed using the constructors of the AST, +-- and these contain information necessary for image sample/read/write operations. +-- +-- === Overview +-- Image operands behave like a linked list of operands, with a /twist/: +-- +-- - the type of an image operand in the list can depend +-- on which operands appear further down in the list. +-- +-- Consider for instance the image operands: +-- +-- @ Grad grad $ Proj $ NilOps @ +-- +-- These can loosely be thought of as a list of operands +-- +-- @ Grad grad : Proj : [] @ +-- +-- This means we are specifying explicit derivatives, +-- and using projective coordinates. +-- +-- However, the fact that we are using projective coordinates +-- means that the explicit derivatives require an extra +-- component (the projective coordinate). +-- +-- In this way, the type of the head of the list +-- depends on the operands appearing in the tail. +data ImageOperands + ( props :: ImageProperties ) + ( ops :: [OperandName] ) + = SomeImageOperands + deriving stock ( Eq, Ord, Show, Bounded, Enum ) + +----------------------------------------------------------- +-- data type for gather image operand + +data Gather + = ComponentGather + | DrefGather + deriving stock ( Show, Eq, Ord, Bounded, Enum ) + +-- | Information hat needs to be provided to the 'Gather' image operand. +-- +-- This consists of 4 offsets, together with the information +-- of which image component (0,1,2,3) to gather +-- in the case that a depth test is /not/ being performed. +-- +-- Instantiated with val ~ AST Word32 (left as a parameter to avoid cylic module dependencies). +data GatherInfo val (gather :: Gather) where + ComponentWithOffsets + :: val -> Array 4 (V 2 Int32) -> GatherInfo val ComponentGather + DepthWithOffsets + :: Array 4 (V 2 Int32) -> GatherInfo val DrefGather + +-- Computes whether a component index needs to be provided to the +-- 'Gather' image operand. +type family WhichGather (ops :: [OperandName]) :: Gather where + WhichGather ops + = If + ( DepthComparison `Elem` ops ) + DrefGather + ComponentGather diff --git a/src/FIR/Prim/Image.hs-boot b/src/FIR/Prim/Image.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/Prim/Image.hs-boot @@ -0,0 +1,86 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module FIR.Prim.Image where + +-- base +import Data.Int + ( Int32 ) +import Data.Kind + ( Type ) +import Data.Type.Bool + ( If ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.List + ( Elem ) +import FIR.Prim.Array + ( Array ) +import Math.Linear + ( V ) +import SPIRV.Image + ( Arrayness(..) + , Dimensionality(..) + , HasDepth(..) + , ImageUsage(..) + , ImageFormat(..) + , MultiSampling(..) + , Operand + ) + +-------------------------------------------------- + +data ImageCoordinateKind + = IntegralCoordinates + | FloatingPointCoordinates + +data ImageProperties where + Properties + :: ImageCoordinateKind + -> Type + -> Dimensionality + -> Maybe HasDepth + -> Arrayness + -> MultiSampling + -> ImageUsage + -> Maybe (ImageFormat Nat) + -> ImageProperties + +data Image (props :: ImageProperties) +type role Image phantom + +data OperandName + = DepthComparison + | ProjectiveCoords + | BaseOperand SPIRV.Image.Operand + +data ImageOperands + ( props :: ImageProperties ) + ( ops :: [OperandName] ) + :: Type +type role ImageOperands phantom phantom + +data Gather + = ComponentGather + | DrefGather + +data GatherInfo val (gather :: Gather) where + ComponentWithOffsets + :: val -> Array 4 (V 2 Int32) -> GatherInfo val ComponentGather + DepthWithOffsets + :: Array 4 (V 2 Int32) -> GatherInfo val DrefGather + +type role GatherInfo representational nominal + +type family WhichGather (ops :: [OperandName]) :: Gather where + WhichGather ops + = If + ( DepthComparison `Elem` ops ) + DrefGather + ComponentGather diff --git a/src/FIR/Prim/Op.hs b/src/FIR/Prim/Op.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Prim/Op.hs @@ -0,0 +1,796 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Prim.Op + +Recall that the AST has a 'FIR.AST.PrimOp' constructor +of the following type: + +> PrimOp :: PrimOp op a +> => Proxy a -> Proxy op -> AST (PrimOpType op a) + +This module provides the wrapper type class 'PrimOp' which relates +the internal SPIR-V operation names (as defined in "SPIRV.PrimOp") +with their types within the context of the AST. + +This module also specifies which operations can be vectorised. +-} + +module FIR.Prim.Op where + +-- base +import Prelude + ( Show(..), Functor(..), fromIntegral ) +import Control.Applicative + ( liftA2 ) +import Data.Proxy + ( Proxy(Proxy) ) +import GHC.TypeNats + ( Nat, KnownNat, natVal ) + +-- fir +import Data.Constraint.All + ( All ) +import FIR.AST.Type + ( AugType(Val, (:-->)), Eff, FunArgs, UnderlyingType, Nullary + , ApplyFAug + ) +import FIR.Prelude +import FIR.Prim.RayTracing + ( AccelerationStructure ) +import FIR.Prim.Types + ( PrimTy, ScalarTy + , primTy, scalarTy + ) +import FIR.ProgramState + ( ProgramState ) +import Math.Linear + ( V, M + , Semimodule((^*)), Inner(dot, normalise), Cross(cross) + , Matrix(..) + ) +import Math.Logic.Bits + ( Bits(..), BitShift(..), BitCast(..) ) +import Math.Logic.Class + ( Boolean(..), Eq(..), Ord(..) ) +import Math.Algebra.Class + ( AdditiveMonoid(..), CancellativeAdditiveMonoid(..), AdditiveGroup(..) + , Semiring(..), Signed(..) + , Archimedean(..) + , DivisionRing(..) + , Floating(..), RealFloat(..) + , Convert(..), Rounding(..) + ) +import qualified SPIRV.PrimOp as SPIRV +import qualified SPIRV.PrimTy as SPIRV + ( PrimTy(..) ) + +------------------------------------------------------------------------------- +-- primitive operations + +class All Nullary ( FunArgs (PrimOpAugType op a) ) => PrimOp (op :: opKind) (a :: k) | op -> k where + type PrimOpAugType op a :: AugType + op :: PrimOpType op a + op = error + ( "unsupported primitive operation " <> show ( opName @_ @_ @op @a ) ) + opName :: SPIRV.PrimOp + opSing :: Maybe (SPrimOp a op) + opSing = Nothing + vectorisation :: KnownNat n => Maybe (VecPrimOpType n op a) + vectorisation = Nothing + +type PrimOpType op a = UnderlyingType ( PrimOpAugType op a ) + +-- some singletons for primitive operations +-- (only defining those that we use in code generation) +data SPrimOp (a :: k) (op :: opKind) :: Type where + SMul :: (ScalarTy a, Semiring a) => SPrimOp a SPIRV.Mul + +-- data type recording type-level information regarding vectorisation of primops +data VecPrimOpType (n :: Nat) op a where + VecPrimOpType + :: ( PrimOp ('Vectorise op) vec + , All PrimTyVal (FunArgs (PrimOpAugType op a)) + , PrimOpAugType ('Vectorise op) vec ~ ApplyFAug (V n) (PrimOpAugType op a) + ) + => Proxy vec -> VecPrimOpType n op a + +newtype Vectorise a = Vectorise a + +class ( v ~ Val (UnderlyingType v), PrimTy (UnderlyingType v) ) => PrimTyVal v +instance ( v ~ Val (UnderlyingType v), PrimTy (UnderlyingType v) ) => PrimTyVal v + +------------------------------------------------------------------------------- +-- instances + +-- boolean operations +instance PrimOp SPIRV.BoolOr Bool where + type PrimOpAugType SPIRV.BoolOr Bool = Val Bool :--> Val Bool :--> Val Bool + op = (||) + opName = SPIRV.BoolOp SPIRV.BoolOr + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BoolOr Bool) + vectorisation = Just $ VecPrimOpType (Proxy @(V n Bool)) +instance PrimOp SPIRV.BoolAnd Bool where + type PrimOpAugType SPIRV.BoolAnd Bool = Val Bool :--> Val Bool :--> Val Bool + op = (&&) + opName = SPIRV.BoolOp SPIRV.BoolAnd + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BoolAnd Bool) + vectorisation = Just $ VecPrimOpType (Proxy @(V n Bool)) +instance PrimOp SPIRV.BoolNot Bool where + type PrimOpAugType SPIRV.BoolNot Bool = Val Bool :--> Val Bool + op = not + opName = SPIRV.BoolOp SPIRV.BoolNot + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BoolNot Bool) + vectorisation = Just $ VecPrimOpType (Proxy @(V n Bool)) + +-- equality operations +instance (PrimTy a, Eq a, Logic a ~ Bool) => PrimOp SPIRV.Equal (a :: Type) where + type PrimOpAugType SPIRV.Equal a = Val a :--> Val a :--> Val Bool + op = (==) + opName = SPIRV.EqOp SPIRV.Equal (primTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Equal a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (PrimTy a, Eq a, Logic a ~ Bool) => PrimOp SPIRV.NotEqual (a :: Type) where + type PrimOpAugType SPIRV.NotEqual a = Val a :--> Val a :--> Val Bool + op = (/=) + opName = SPIRV.EqOp SPIRV.NotEqual (primTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.NotEqual a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) + +-- comparison +instance (ScalarTy a, Ord a, Logic a ~ Bool) => PrimOp SPIRV.GT (a :: Type) where + type PrimOpAugType SPIRV.GT a = Val a :--> Val a :--> Val Bool + op = (>) + opName = SPIRV.OrdOp SPIRV.GT (scalarTy @a) +instance (ScalarTy a, Ord a, Logic a ~ Bool) => PrimOp SPIRV.GTE (a :: Type) where + type PrimOpAugType SPIRV.GTE a = Val a :--> Val a :--> Val Bool + op = (>=) + opName = SPIRV.OrdOp SPIRV.GTE (scalarTy @a) +instance (ScalarTy a, Ord a, Logic a ~ Bool) => PrimOp SPIRV.LT (a :: Type) where + type PrimOpAugType SPIRV.LT a = Val a :--> Val a :--> Val Bool + op = (<) + opName = SPIRV.OrdOp SPIRV.LT (scalarTy @a) +instance (ScalarTy a, Ord a, Logic a ~ Bool) => PrimOp SPIRV.LTE (a :: Type) where + type PrimOpAugType SPIRV.LTE a = Val a :--> Val a :--> Val Bool + op = (<=) + opName = SPIRV.OrdOp SPIRV.LTE (scalarTy @a) +instance (ScalarTy a, Ord a, Logic a ~ Bool) => PrimOp SPIRV.Min (a :: Type) where + type PrimOpAugType SPIRV.Min a = Val a :--> Val a :--> Val a + op = min + opName = SPIRV.OrdOp SPIRV.Min (scalarTy @a) +instance (ScalarTy a, Ord a, Logic a ~ Bool) => PrimOp SPIRV.Max (a :: Type) where + type PrimOpAugType SPIRV.Max a = Val a :--> Val a :--> Val a + op = max + opName = SPIRV.OrdOp SPIRV.Max (scalarTy @a) + +-- bitwise operations +instance (ScalarTy a, Bits a) => PrimOp SPIRV.BitAnd (a :: Type) where + type PrimOpAugType SPIRV.BitAnd a = Val a :--> Val a :--> Val a + op = (.&.) + opName = SPIRV.BitOp SPIRV.BitAnd (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BitAnd a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Bits a) => PrimOp SPIRV.BitOr (a :: Type) where + type PrimOpAugType SPIRV.BitOr a = Val a :--> Val a :--> Val a + op = (.|.) + opName = SPIRV.BitOp SPIRV.BitOr (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BitOr a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Bits a) => PrimOp SPIRV.BitXor (a :: Type) where + type PrimOpAugType SPIRV.BitXor a = Val a :--> Val a :--> Val a + op = xor + opName = SPIRV.BitOp SPIRV.BitXor (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BitXor a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Bits a) => PrimOp SPIRV.BitNot (a :: Type) where + type PrimOpAugType SPIRV.BitNot a = Val a :--> Val a + op = complement + opName = SPIRV.BitOp SPIRV.BitNot (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BitNot a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Bits a) => PrimOp SPIRV.ReverseBits (a :: Type) where + type PrimOpAugType SPIRV.ReverseBits a = Val a :--> Val a + op = bitReverse + opName = SPIRV.BitOp SPIRV.ReverseBits (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.ReverseBits a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance forall (b :: Type) (s :: Type). (ScalarTy b, PrimTy s, BitShift '(b,s)) + => PrimOp SPIRV.BitShiftRight '(b,s) where + type PrimOpAugType SPIRV.BitShiftRight '(b,s) = Val b :--> Val s :--> Val b + op = shiftR + opName = SPIRV.BitOp SPIRV.BitShiftRight (scalarTy @b) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BitShiftRight '(b,s)) + vectorisation = Just $ VecPrimOpType (Proxy @'(V n b, V n s)) +instance forall (b :: Type) (s :: Type). (ScalarTy b, PrimTy s, BitShift '(b,s)) + => PrimOp SPIRV.BitShiftLeft '(b,s) where + type PrimOpAugType SPIRV.BitShiftLeft '(b,s) = Val b :--> Val s :--> Val b + op = shiftL + opName = SPIRV.BitOp SPIRV.BitShiftLeft (scalarTy @b) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.BitShiftLeft '(b,s)) + vectorisation = Just $ VecPrimOpType (Proxy @'(V n b, V n s)) + +-- bitcast operation +instance (ScalarTy a, ScalarTy b, BitCast a b) => PrimOp SPIRV.CastOp '(a,b) where + type PrimOpAugType SPIRV.CastOp '(a,b) = Val a :--> Val b + op = bitcast + opName = SPIRV.CastOp (primTy @b) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.CastOp '(a,b)) + vectorisation = Just $ VecPrimOpType (Proxy @'(V n a, V n b)) + +-- numeric operations +instance (ScalarTy a, AdditiveMonoid a) => PrimOp SPIRV.Add (a :: Type) where + type PrimOpAugType SPIRV.Add a = Val a :--> Val a :--> Val a + op = (+) + opName = SPIRV.NumOp SPIRV.Add (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Add a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Semiring a) => PrimOp SPIRV.Mul (a :: Type) where + type PrimOpAugType SPIRV.Mul a = Val a :--> Val a :--> Val a + op = (*) + opName = SPIRV.NumOp SPIRV.Mul (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Mul a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) + opSing = Just SMul +instance (ScalarTy a, CancellativeAdditiveMonoid a) => PrimOp SPIRV.Sub (a :: Type) where + type PrimOpAugType SPIRV.Sub a = Val a :--> Val a :--> Val a + op = (-) + opName = SPIRV.NumOp SPIRV.Sub (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Sub a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, AdditiveGroup a) => PrimOp SPIRV.Neg (a :: Type) where + type PrimOpAugType SPIRV.Neg a = Val a :--> Val a + op = negate + opName = SPIRV.NumOp SPIRV.Neg (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Neg a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Signed a) => PrimOp SPIRV.Abs (a :: Type) where + type PrimOpAugType SPIRV.Abs a = Val a :--> Val a + op = abs + opName = SPIRV.NumOp SPIRV.Abs (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Abs a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Signed a) => PrimOp SPIRV.Sign (a :: Type) where + type PrimOpAugType SPIRV.Sign a = Val a :--> Val a + op = signum + opName = SPIRV.NumOp SPIRV.Sign (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Sign a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, DivisionRing a) => PrimOp SPIRV.Div (a :: Type) where + type PrimOpAugType SPIRV.Div a = Val a :--> Val a :--> Val a + op = (/) + opName = SPIRV.NumOp SPIRV.Div (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Div a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Archimedean a) => PrimOp SPIRV.Mod (a :: Type) where + type PrimOpAugType SPIRV.Mod a = Val a :--> Val a :--> Val a + op = mod + opName = SPIRV.NumOp SPIRV.Mod (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Mod a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Archimedean a) => PrimOp SPIRV.Rem (a :: Type) where + type PrimOpAugType SPIRV.Rem a = Val a :--> Val a :--> Val a + op = rem + opName = SPIRV.NumOp SPIRV.Rem (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Rem a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Archimedean a) => PrimOp SPIRV.Quot (a :: Type) where + type PrimOpAugType SPIRV.Quot a = Val a :--> Val a :--> Val a + op = div + opName = SPIRV.NumOp SPIRV.Quot (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Quot a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) + + +-- floating operations +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FSin (a :: Type) where + type PrimOpAugType SPIRV.FSin a = Val a :--> Val a + op = sin + opName = SPIRV.FloatOp SPIRV.FSin (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FSin a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FCos (a :: Type) where + type PrimOpAugType SPIRV.FCos a = Val a :--> Val a + op = cos + opName = SPIRV.FloatOp SPIRV.FCos (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FCos a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FTan (a :: Type) where + type PrimOpAugType SPIRV.FTan a = Val a :--> Val a + op = tan + opName = SPIRV.FloatOp SPIRV.FTan (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FTan a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FAsin (a :: Type) where + type PrimOpAugType SPIRV.FAsin a = Val a :--> Val a + op = asin + opName = SPIRV.FloatOp SPIRV.FAsin (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAsin a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FAcos (a :: Type) where + type PrimOpAugType SPIRV.FAcos a = Val a :--> Val a + op = acos + opName = SPIRV.FloatOp SPIRV.FAcos (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAcos a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FAtan (a :: Type) where + type PrimOpAugType SPIRV.FAtan a = Val a :--> Val a + op = atan + opName = SPIRV.FloatOp SPIRV.FAtan (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAtan a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FSinh (a :: Type) where + type PrimOpAugType SPIRV.FSinh a = Val a :--> Val a + op = sinh + opName = SPIRV.FloatOp SPIRV.FSinh (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FSinh a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FCosh (a :: Type) where + type PrimOpAugType SPIRV.FCosh a = Val a :--> Val a + op = cosh + opName = SPIRV.FloatOp SPIRV.FCosh (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FCosh a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FTanh (a :: Type) where + type PrimOpAugType SPIRV.FTanh a = Val a :--> Val a + op = tanh + opName = SPIRV.FloatOp SPIRV.FTanh (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FTanh a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FAsinh (a :: Type) where + type PrimOpAugType SPIRV.FAsinh a = Val a :--> Val a + op = asinh + opName = SPIRV.FloatOp SPIRV.FAsinh (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAsinh a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FAcosh (a :: Type) where + type PrimOpAugType SPIRV.FAcosh a = Val a :--> Val a + op = acosh + opName = SPIRV.FloatOp SPIRV.FAcosh (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAcosh a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FAtanh (a :: Type) where + type PrimOpAugType SPIRV.FAtanh a = Val a :--> Val a + op = atanh + opName = SPIRV.FloatOp SPIRV.FAtanh (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAtanh a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, RealFloat a) => PrimOp SPIRV.FAtan2 (a :: Type) where + type PrimOpAugType SPIRV.FAtan2 a = Val a :--> Val a :--> Val a + op = atan2 + opName = SPIRV.FloatOp SPIRV.FAtan2 (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FAtan2 a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FPow (a :: Type) where + type PrimOpAugType SPIRV.FPow a = Val a :--> Val a :--> Val a + op = (**) + opName = SPIRV.FloatOp SPIRV.FPow (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FPow a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FExp (a :: Type) where + type PrimOpAugType SPIRV.FExp a = Val a :--> Val a + op = exp + opName = SPIRV.FloatOp SPIRV.FExp (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FExp a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FLog (a :: Type) where + type PrimOpAugType SPIRV.FLog a = Val a :--> Val a + op = log + opName = SPIRV.FloatOp SPIRV.FLog (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FLog a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FSqrt (a :: Type) where + type PrimOpAugType SPIRV.FSqrt a = Val a :--> Val a + op = sqrt + opName = SPIRV.FloatOp SPIRV.FSqrt (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FSqrt a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, Floating a) => PrimOp SPIRV.FInvSqrt (a :: Type) where + type PrimOpAugType SPIRV.FInvSqrt a = Val a :--> Val a + op = recip . sqrt + opName = SPIRV.FloatOp SPIRV.FInvSqrt (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FInvSqrt a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, RealFloat a, Logic a ~ Bool) => PrimOp SPIRV.FIsNaN (a :: Type) where + type PrimOpAugType SPIRV.FIsNaN a = Val a :--> Val Bool + op = isNaN + opName = SPIRV.FloatOp SPIRV.FIsNaN (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FIsNaN a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) +instance (ScalarTy a, RealFloat a, Logic a ~ Bool) => PrimOp SPIRV.FIsInf (a :: Type) where + type PrimOpAugType SPIRV.FIsInf a = Val a :--> Val Bool + op = isInfinite + opName = SPIRV.FloatOp SPIRV.FIsInf (scalarTy @a) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.FIsInf a) + vectorisation = Just $ VecPrimOpType (Proxy @(V n a)) + +-- numeric conversions +instance ( ScalarTy a, ScalarTy b, Convert '(a,b) ) => PrimOp SPIRV.Convert '(a,b) where + type PrimOpAugType SPIRV.Convert '(a,b) = Val a :--> Val b + op = convert + opName = SPIRV.ConvOp SPIRV.Convert (scalarTy @a) (scalarTy @b) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.Convert '(a,b)) + vectorisation = Just $ VecPrimOpType (Proxy @'(V n a, V n b)) +instance ( ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp SPIRV.CTruncate '(a,b) where + type PrimOpAugType SPIRV.CTruncate '(a,b) = Val a :--> Val b + op = truncate + opName = SPIRV.ConvOp SPIRV.CTruncate (scalarTy @a) (scalarTy @b) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.CTruncate '(a,b)) + vectorisation = Just $ VecPrimOpType (Proxy @'(V n a, V n b)) +instance ( ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp SPIRV.CRound '(a,b) where + type PrimOpAugType SPIRV.CRound '(a,b) = Val a :--> Val b + op = round + opName = SPIRV.ConvOp SPIRV.CRound (scalarTy @a) (scalarTy @b) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.CRound '(a,b)) + vectorisation = Just $ VecPrimOpType (Proxy @'(V n a, V n b)) +instance ( ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp SPIRV.CFloor '(a,b) where + type PrimOpAugType SPIRV.CFloor '(a,b) = Val a :--> Val b + op = floor + opName = SPIRV.ConvOp SPIRV.CFloor (scalarTy @a) (scalarTy @b) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.CFloor '(a,b)) + vectorisation = Just $ VecPrimOpType (Proxy @'(V n a, V n b)) +instance ( ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp SPIRV.CCeiling '(a,b) where + type PrimOpAugType SPIRV.CCeiling '(a,b) = Val a :--> Val b + op = ceiling + opName = SPIRV.ConvOp SPIRV.CCeiling (scalarTy @a) (scalarTy @b) + vectorisation :: forall n. KnownNat n => Maybe (VecPrimOpType n SPIRV.CCeiling '(a,b)) + vectorisation = Just $ VecPrimOpType (Proxy @'(V n a, V n b)) + +-- geometry primitive instructions +instance PrimOp SPIRV.EmitGeometryVertex (i :: ProgramState) where + type PrimOpAugType SPIRV.EmitGeometryVertex i = Eff i i () + opName = SPIRV.GeomOp SPIRV.EmitGeometryVertex +instance PrimOp SPIRV.EndGeometryPrimitive (i :: ProgramState) where + type PrimOpAugType SPIRV.EndGeometryPrimitive i = Eff i i () + opName = SPIRV.GeomOp SPIRV.EndGeometryPrimitive + +-- memory synchronisation instructions +instance PrimOp SPIRV.ControlSync (i :: ProgramState) where + type PrimOpAugType SPIRV.ControlSync i = Val Word32 :--> Val Word32 :--> Val Word32 :--> Eff i i () + opName = SPIRV.SyncOp SPIRV.ControlSync +instance PrimOp SPIRV.MemorySync (i :: ProgramState) where + type PrimOpAugType SPIRV.MemorySync i = Val Word32 :--> Val Word32 :--> Eff i i () + opName = SPIRV.SyncOp SPIRV.MemorySync + +-- non uniform subgroup instructions +instance ( ScalarTy a, AdditiveMonoid a) => PrimOp SPIRV.GroupAdd '(i :: ProgramState, a) where + type PrimOpAugType SPIRV.GroupAdd '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a + opName = SPIRV.GroupOp $ SPIRV.GroupNumOp SPIRV.GroupAdd (scalarTy @a) +instance ( ScalarTy a, Semiring a) => PrimOp SPIRV.GroupMul '(i :: ProgramState, a) where + type PrimOpAugType SPIRV.GroupMul '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a + opName = SPIRV.GroupOp $ SPIRV.GroupNumOp SPIRV.GroupMul (scalarTy @a) +instance ( ScalarTy a, Ord a) => PrimOp SPIRV.GroupMin '(i :: ProgramState, a) where + type PrimOpAugType SPIRV.GroupMin '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a + opName = SPIRV.GroupOp $ SPIRV.GroupNumOp SPIRV.GroupMin (scalarTy @a) +instance ( ScalarTy a, Ord a) => PrimOp SPIRV.GroupMax '(i :: ProgramState, a) where + type PrimOpAugType SPIRV.GroupMax '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a + opName = SPIRV.GroupOp $ SPIRV.GroupNumOp SPIRV.GroupMax (scalarTy @a) +instance ( ScalarTy a ) => PrimOp SPIRV.GroupBitwiseAnd '(i :: ProgramState, a) where + type PrimOpAugType SPIRV.GroupBitwiseAnd '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a + opName = SPIRV.GroupOp $ SPIRV.GroupBitwiseOp SPIRV.GroupBitwiseAnd (scalarTy @a) +instance ( ScalarTy a ) => PrimOp SPIRV.GroupBitwiseOr '(i :: ProgramState, a) where + type PrimOpAugType SPIRV.GroupBitwiseOr '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a + opName = SPIRV.GroupOp $ SPIRV.GroupBitwiseOp SPIRV.GroupBitwiseOr (scalarTy @a) +instance ( ScalarTy a ) => PrimOp SPIRV.GroupBitwiseXor '(i :: ProgramState, a) where + type PrimOpAugType SPIRV.GroupBitwiseXor '(i,a) = Val Word32 :--> Val Word32 :--> Val a :--> Eff i i a + opName = SPIRV.GroupOp $ SPIRV.GroupBitwiseOp SPIRV.GroupBitwiseXor (scalarTy @a) +instance PrimOp SPIRV.GroupLogicalAnd (i :: ProgramState) where + type PrimOpAugType SPIRV.GroupLogicalAnd i = Val Word32 :--> Val Word32 :--> Val Bool :--> Eff i i Bool + opName = SPIRV.GroupOp $ SPIRV.GroupLogicOp SPIRV.GroupLogicalAnd +instance PrimOp SPIRV.GroupLogicalOr (i :: ProgramState) where + type PrimOpAugType SPIRV.GroupLogicalOr i = Val Word32 :--> Val Word32 :--> Val Bool :--> Eff i i Bool + opName = SPIRV.GroupOp $ SPIRV.GroupLogicOp SPIRV.GroupLogicalOr +instance PrimOp SPIRV.GroupLogicalXor (i :: ProgramState) where + type PrimOpAugType SPIRV.GroupLogicalXor i = Val Word32 :--> Val Word32 :--> Val Bool :--> Eff i i Bool + opName = SPIRV.GroupOp $ SPIRV.GroupLogicOp SPIRV.GroupLogicalXor + +-- ray tracing instructions +instance PrimOp SPIRV.RT_ReportIntersection (i :: ProgramState) where + type PrimOpAugType SPIRV.RT_ReportIntersection i = Val Float :--> Val Word32 :--> Eff i i Bool + opName = SPIRV.RayOp SPIRV.RT_ReportIntersection +instance PrimOp SPIRV.RT_IgnoreIntersection (i :: ProgramState) where + type PrimOpAugType SPIRV.RT_IgnoreIntersection i = Eff i i () + opName = SPIRV.RayOp SPIRV.RT_IgnoreIntersection +instance PrimOp SPIRV.RT_TerminateRay (i :: ProgramState) where + type PrimOpAugType SPIRV.RT_TerminateRay i = Eff i i () + opName = SPIRV.RayOp SPIRV.RT_TerminateRay +instance PrimOp SPIRV.RT_AccelerationStructureFromDeviceAddress '() where + type PrimOpAugType SPIRV.RT_AccelerationStructureFromDeviceAddress _ = Val Word64 :--> Val AccelerationStructure + opName = SPIRV.RayOp SPIRV.RT_AccelerationStructureFromDeviceAddress + +-- vector operations +-- doing it by hand because I'm an idiot who doesn't know better + +val :: forall n. KnownNat n => Word32 +val = fromIntegral ( natVal (Proxy @n) ) + + +instance KnownNat n => PrimOp ('Vectorise SPIRV.BoolOr) (V n Bool) where + type PrimOpAugType ('Vectorise SPIRV.BoolOr) (V n Bool) = Val (V n Bool) :--> Val (V n Bool) :--> Val (V n Bool) + op = liftA2 (||) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BoolOr @Bool)) (val @n) SPIRV.Boolean +instance KnownNat n => PrimOp ('Vectorise SPIRV.BoolAnd) (V n Bool) where + type PrimOpAugType ('Vectorise SPIRV.BoolAnd) (V n Bool) = Val (V n Bool) :--> Val (V n Bool) :--> Val (V n Bool) + op = liftA2 (&&) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BoolAnd @Bool)) (val @n) SPIRV.Boolean +instance KnownNat n => PrimOp ('Vectorise SPIRV.BoolNot) (V n Bool) where + type PrimOpAugType ('Vectorise SPIRV.BoolNot) (V n Bool) = Val (V n Bool) :--> Val (V n Bool) + op = fmap not + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BoolNot @Bool)) (val @n) SPIRV.Boolean + +instance ( KnownNat n, PrimTy a, Eq a, Logic a ~ Bool ) => PrimOp ('Vectorise SPIRV.Equal) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.Equal) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n Bool) + op = liftA2 (==) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Equal @a)) (val @n) SPIRV.Boolean +instance ( KnownNat n, PrimTy a, Eq a, Logic a ~ Bool ) => PrimOp ('Vectorise SPIRV.NotEqual) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.NotEqual) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n Bool) + op = liftA2 (/=) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.NotEqual @a)) (val @n) SPIRV.Boolean + +instance (KnownNat n, ScalarTy a, AdditiveMonoid a) => PrimOp ('Vectorise SPIRV.GroupAdd) '(i :: ProgramState, V n a) where + type PrimOpAugType ('Vectorise SPIRV.GroupAdd) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.GroupAdd @'(i, a))) (val @n) (primTy @a) +instance (KnownNat n, ScalarTy a, Semiring a) => PrimOp ('Vectorise SPIRV.GroupMul) '(i :: ProgramState, V n a) where + type PrimOpAugType ('Vectorise SPIRV.GroupMul) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.GroupMul @'(i, a))) (val @n) (primTy @a) +instance (KnownNat n, ScalarTy a, Ord a) => PrimOp ('Vectorise SPIRV.GroupMin) '(i :: ProgramState, V n a) where + type PrimOpAugType ('Vectorise SPIRV.GroupMin) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.GroupMin @'(i, a))) (val @n) (primTy @a) +instance (KnownNat n, ScalarTy a, Ord a) => PrimOp ('Vectorise SPIRV.GroupMax) '(i :: ProgramState, V n a) where + type PrimOpAugType ('Vectorise SPIRV.GroupMax) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.GroupMax @'(i, a))) (val @n) (primTy @a) +instance (KnownNat n, ScalarTy a, Bits a) => PrimOp ('Vectorise SPIRV.GroupBitwiseAnd) '(i :: ProgramState, V n a) where + type PrimOpAugType ('Vectorise SPIRV.GroupBitwiseAnd) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.GroupBitwiseAnd @'(i, a))) (val @n) (primTy @a) +instance (KnownNat n, ScalarTy a, Bits a) => PrimOp ('Vectorise SPIRV.GroupBitwiseOr) '(i :: ProgramState, V n a) where + type PrimOpAugType ('Vectorise SPIRV.GroupBitwiseOr) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.GroupBitwiseOr @'(i, a))) (val @n) (primTy @a) +instance (KnownNat n, ScalarTy a, Bits a) => PrimOp ('Vectorise SPIRV.GroupBitwiseXor) '(i :: ProgramState, V n a) where + type PrimOpAugType ('Vectorise SPIRV.GroupBitwiseXor) '(i,V n a) = Val Word32 :--> Val Word32 :--> Val (V n a) :--> Eff i i (V n a) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.GroupBitwiseXor @'(i, a))) (val @n) (primTy @a) +instance (KnownNat n) => PrimOp ('Vectorise SPIRV.GroupLogicalAnd) '(i :: ProgramState, n :: Nat) where + type PrimOpAugType ('Vectorise SPIRV.GroupLogicalAnd) '(i,n) = Val Word32 :--> Val Word32 :--> Val (V n Bool) :--> Eff i i (V n Bool) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.GroupLogicalAnd @i)) (val @n) SPIRV.Boolean +instance (KnownNat n) => PrimOp ('Vectorise SPIRV.GroupLogicalOr) '(i :: ProgramState, n :: Nat) where + type PrimOpAugType ('Vectorise SPIRV.GroupLogicalOr) '(i,n) = Val Word32 :--> Val Word32 :--> Val (V n Bool) :--> Eff i i (V n Bool) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.GroupLogicalOr @i)) (val @n) SPIRV.Boolean +instance (KnownNat n) => PrimOp ('Vectorise SPIRV.GroupLogicalXor) '(i :: ProgramState, n :: Nat) where + type PrimOpAugType ('Vectorise SPIRV.GroupLogicalXor) '(i,n) = Val Word32 :--> Val Word32 :--> Val (V n Bool) :--> Eff i i (V n Bool) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.GroupLogicalXor @i)) (val @n) SPIRV.Boolean + +instance ( KnownNat n, ScalarTy a, Bits a ) => PrimOp ('Vectorise SPIRV.BitAnd) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.BitAnd) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a) + op = liftA2 (.&.) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BitAnd @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Bits a ) => PrimOp ('Vectorise SPIRV.BitOr) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.BitOr) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a) + op = liftA2 (.|.) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BitOr @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Bits a ) => PrimOp ('Vectorise SPIRV.BitXor) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.BitXor) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a) + op = liftA2 xor + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BitXor @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Bits a ) => PrimOp ('Vectorise SPIRV.BitNot) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.BitNot) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap complement + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BitNot @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Bits a ) => PrimOp ('Vectorise SPIRV.ReverseBits) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.ReverseBits) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap bitReverse + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.ReverseBits @a)) (val @n) (primTy @a) + +instance ( KnownNat n, ScalarTy a, ScalarTy b, BitCast a b ) => PrimOp ('Vectorise SPIRV.CastOp) '(V n a, V n b) where + type PrimOpAugType ('Vectorise SPIRV.CastOp) '(V n a, V n b) = Val (V n a) :--> Val (V n b) + op = fmap bitcast + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.CastOp @'(a,b))) (val @n) (primTy @b) + +instance ( KnownNat n, ScalarTy b, PrimTy s, BitShift '(b,s) ) => PrimOp ('Vectorise SPIRV.BitShiftRight) '(V n b, V n s) where + type PrimOpAugType ('Vectorise SPIRV.BitShiftRight) '(V n b, V n s) = Val (V n b) :--> Val (V n s) :--> Val (V n b) + op = liftA2 shiftR + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BitShiftRight @'(b,s))) (val @n) (primTy @b) +instance ( KnownNat n, ScalarTy b, PrimTy s, BitShift '(b,s) ) => PrimOp ('Vectorise SPIRV.BitShiftLeft) '(V n b, V n s) where + type PrimOpAugType ('Vectorise SPIRV.BitShiftLeft) '(V n b, V n s) = Val (V n b) :--> Val (V n s) :--> Val (V n b) + op = liftA2 shiftL + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.BitShiftLeft @'(b,s))) (val @n) (primTy @b) + +instance ( KnownNat n, ScalarTy a, AdditiveMonoid a ) => PrimOp ('Vectorise SPIRV.Add) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.Add) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a) + op = liftA2 (+) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Add @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, CancellativeAdditiveMonoid a ) => PrimOp ('Vectorise SPIRV.Sub) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.Sub) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a) + op = liftA2 (-) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Sub @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, AdditiveGroup a ) => PrimOp ('Vectorise SPIRV.Neg) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.Neg) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap negate + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Neg @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Semiring a ) => PrimOp ('Vectorise SPIRV.Mul) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.Mul) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a) + op = liftA2 (*) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Mul @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Signed a ) => PrimOp ('Vectorise SPIRV.Abs) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.Abs) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap abs + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Abs @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Signed a ) => PrimOp ('Vectorise SPIRV.Sign) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.Sign) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap signum + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Sign @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, DivisionRing a ) => PrimOp ('Vectorise SPIRV.Div) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.Div) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a) + op = liftA2 (/) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Div @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Archimedean a ) => PrimOp ('Vectorise SPIRV.Mod) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.Mod) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a) + op = liftA2 mod + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Mod @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Archimedean a ) => PrimOp ('Vectorise SPIRV.Rem) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.Rem) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a) + op = liftA2 rem + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Rem @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Archimedean a ) => PrimOp ('Vectorise SPIRV.Quot) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.Quot) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a) + op = liftA2 div + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Quot @a)) (val @n) (primTy @a) + +instance ( KnownNat n, ScalarTy a, ScalarTy b, Convert '(a,b) ) => PrimOp ('Vectorise SPIRV.Convert) '(V n a, V n b) where + type PrimOpAugType ('Vectorise SPIRV.Convert) '(V n a, V n b) = Val (V n a) :--> Val (V n b) + op = fmap convert + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.Convert @'(a,b))) (val @n) (primTy @b) +instance ( KnownNat n, ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp ('Vectorise SPIRV.CTruncate) '(V n a, V n b) where + type PrimOpAugType ('Vectorise SPIRV.CTruncate) '(V n a, V n b) = Val (V n a) :--> Val (V n b) + op = fmap truncate + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.CTruncate @'(a,b))) (val @n) (primTy @b) +instance ( KnownNat n, ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp ('Vectorise SPIRV.CRound) '(V n a, V n b) where + type PrimOpAugType ('Vectorise SPIRV.CRound) '(V n a, V n b) = Val (V n a) :--> Val (V n b) + op = fmap round + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.CRound @'(a,b))) (val @n) (primTy @b) +instance ( KnownNat n, ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp ('Vectorise SPIRV.CFloor) '(V n a, V n b) where + type PrimOpAugType ('Vectorise SPIRV.CFloor) '(V n a, V n b) = Val (V n a) :--> Val (V n b) + op = fmap floor + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.CFloor @'(a,b))) (val @n) (primTy @b) +instance ( KnownNat n, ScalarTy a, ScalarTy b, Rounding '(a,b) ) => PrimOp ('Vectorise SPIRV.CCeiling) '(V n a, V n b) where + type PrimOpAugType ('Vectorise SPIRV.CCeiling) '(V n a, V n b) = Val (V n a) :--> Val (V n b) + op = fmap ceiling + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.CCeiling @'(a,b))) (val @n) (primTy @b) + +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FSin) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FSin) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap sin + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FSin @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FCos) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FCos) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap cos + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FCos @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FTan) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FTan) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap tan + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FTan @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FAsin) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FAsin) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap asin + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAsin @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FAcos) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FAcos) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap acos + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAcos @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FAtan) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FAtan) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap atan + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAtan @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FSinh) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FSinh) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap sinh + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FSinh @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FCosh) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FCosh) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap cosh + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FCosh @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FTanh) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FTanh) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap tanh + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FTanh @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FAsinh) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FAsinh) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap asinh + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAsinh @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FAcosh) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FAcosh) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap acosh + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAcosh @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FAtanh) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FAtanh) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap atanh + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAtanh @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, RealFloat a ) => PrimOp ('Vectorise SPIRV.FAtan2) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FAtan2) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a) + op = liftA2 atan2 + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FAtan2 @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FPow) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FPow) (V n a) = Val (V n a) :--> Val (V n a) :--> Val (V n a) + op = liftA2 (**) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FPow @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FExp) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FExp) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap exp + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FExp @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FLog) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FLog) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap log + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FLog @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FSqrt) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FSqrt) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap sqrt + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FSqrt @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp ('Vectorise SPIRV.FInvSqrt) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FInvSqrt) (V n a) = Val (V n a) :--> Val (V n a) + op = fmap ( recip . sqrt ) + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FInvSqrt @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, RealFloat a, Logic a ~ Bool) => PrimOp ('Vectorise SPIRV.FIsNaN) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FIsNaN) (V n a) = Val (V n a) :--> Val (V n Bool) + op = fmap isNaN + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FIsNaN @a)) (val @n) (primTy @a) +instance ( KnownNat n, ScalarTy a, RealFloat a, Logic a ~ Bool) => PrimOp ('Vectorise SPIRV.FIsInf) (V n a) where + type PrimOpAugType ('Vectorise SPIRV.FIsInf) (V n a) = Val (V n a) :--> Val (V n Bool) + op = fmap isInfinite + opName = SPIRV.VecOp (SPIRV.Vectorise (opName @_ @_ @SPIRV.FIsInf @a)) (val @n) (primTy @a) + +instance ( KnownNat n, ScalarTy a, Floating a ) => PrimOp SPIRV.DotV (V n a) where + type PrimOpAugType SPIRV.DotV (V n a) = Val (V n a) :--> Val (V n a) :--> Val a + op = dot + opName = SPIRV.VecOp SPIRV.DotV (val @n) (primTy @a) +-- vector times scalar operation requires floating point type in SPIR-V +instance ( KnownNat n, ScalarTy a, Semiring a, Floating a ) => PrimOp SPIRV.VMulK (V n a) where + type PrimOpAugType SPIRV.VMulK (V n a) = Val (V n a) :--> Val a :--> Val (V n a) + op = (^*) + opName = SPIRV.VecOp SPIRV.VMulK (val @n) (primTy @a) +instance ( n ~ 3, ScalarTy a, Floating a ) => PrimOp SPIRV.CrossV (V n a) where + type PrimOpAugType SPIRV.CrossV (V n a) = Val (V 3 a) :--> Val (V 3 a) :--> Val (V 3 a) + op = cross + opName = SPIRV.VecOp SPIRV.CrossV 3 (primTy @a) +instance ( KnownNat n, ScalarTy a, Floating a) => PrimOp SPIRV.NormaliseV (V n a) where + type PrimOpAugType SPIRV.NormaliseV (V n a) = Val (V n a) :--> Val (V n a) + op = normalise + opName = SPIRV.VecOp SPIRV.NormaliseV (val @n) (primTy @a) + + +instance ( KnownNat i, KnownNat j, ScalarTy a, Floating a ) => PrimOp SPIRV.MMulK '(a,i,j) where + type PrimOpAugType SPIRV.MMulK '(a,i,j) = Val (M i j a) :--> Val a :--> Val (M i j a) + op = (!*) + opName = SPIRV.MatOp SPIRV.MMulK (val @i) (val @j) (scalarTy @a) +instance ( KnownNat i, KnownNat j, ScalarTy a, Floating a ) => PrimOp SPIRV.MMulV '(a,i,j) where + type PrimOpAugType SPIRV.MMulV '(a,i,j) = Val (M i j a) :--> Val (V j a) :--> Val (V i a) + op = (!*^) + opName = SPIRV.MatOp SPIRV.MMulV (val @i) (val @j) (scalarTy @a) +instance ( KnownNat i, KnownNat j, ScalarTy a, Floating a ) => PrimOp SPIRV.VMulM '(a,i,j) where + type PrimOpAugType SPIRV.VMulM '(a,i,j) = Val (V i a) :--> Val (M i j a) :--> Val (V j a) + op = (^*!) + opName = SPIRV.MatOp SPIRV.VMulM (val @i) (val @j) (scalarTy @a) +instance ( KnownNat i, KnownNat j, KnownNat k, ScalarTy a, Floating a ) => PrimOp SPIRV.MMulM '(a,i,j,k) where + type PrimOpAugType SPIRV.MMulM '(a,i,j,k) = Val (M i j a) :--> Val (M j k a) :--> Val (M i k a) + op = (!*!) + opName = SPIRV.MatOp SPIRV.MMulM (val @i) (val @k) (scalarTy @a) +instance ( KnownNat i, KnownNat j, ScalarTy a, Floating a ) => PrimOp SPIRV.Transp '(a,i,j) where + type PrimOpAugType SPIRV.Transp '(a,i,j) = Val (M i j a) :--> Val (M j i a) + op = transpose + opName = SPIRV.MatOp SPIRV.Transp (val @j) (val @i) (scalarTy @a) +instance ( KnownNat i, ScalarTy a, Floating a ) => PrimOp SPIRV.Det '(a,i) where + type PrimOpAugType SPIRV.Det '(a,i) = Val (M i i a) :--> Val a + op = determinant + opName = SPIRV.MatOp SPIRV.Det (val @i) (val @i) (scalarTy @a) +instance ( KnownNat i, ScalarTy a, Floating a ) => PrimOp SPIRV.Inv '(a,i) where + type PrimOpAugType SPIRV.Inv '(a,i) = Val (M i i a) :--> Val (M i i a) + op = inverse + opName = SPIRV.MatOp SPIRV.Inv (val @i) (val @i) (scalarTy @a) diff --git a/src/FIR/Prim/RayTracing.hs b/src/FIR/Prim/RayTracing.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Prim/RayTracing.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module: FIR.Prim.RayTracing + +This module defines the opaque 'AccelerationStructure' and 'RayQuery' types, +to be used to refer to such objects in ray tracing operations. +-} + +module FIR.Prim.RayTracing where + +-- base +import Data.Word + ( Word64 ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- fir +import Data.Type.Known + ( Demotable(..), Known(..) ) + +------------------------------------------------------------ + +newtype AccelerationStructure = AccelerationStructureFromWord64 Word64 + deriving stock ( Show, Eq, Ord ) +newtype RayQuery = RayQuery ShortText -- refer to the ray query by its name internally (not exported by the library) + deriving stock ( Show, Eq, Ord ) + +data RayQueryState + = RayQueryState + ( Maybe RayQueryProceedState ) + ( Maybe RayQueryCommittedIntersection ) + deriving stock ( Show, Eq, Ord ) + +data RayQueryProceedState + = Complete + | Incomplete ( Maybe RayQueryCandidateIntersection ) + deriving stock ( Show, Eq, Ord ) + +data IntersectionType + = Candidate + | Committed + deriving stock ( Show, Eq, Ord ) + +data RayQueryCandidateIntersection + = TriangleCandidateIntersection + | AABBCandidateIntersection + deriving stock ( Show, Eq, Ord ) +data RayQueryCommittedIntersection + = NoIntersection + | TriangleIntersection + | GeneratedIntersection + deriving stock ( Show, Eq, Ord ) + +instance Demotable IntersectionType where + type Demote IntersectionType = IntersectionType + +instance Known IntersectionType Candidate where + known = Candidate +instance Known IntersectionType Committed where + known = Committed diff --git a/src/FIR/Prim/Struct.hs b/src/FIR/Prim/Struct.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Prim/Struct.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Prim.Struct + +A __structure__ (or __struct__ for short) can be thought of as an ordered record. + +Here, we simply represent a struct as a linked list, with the fields annotated at the type level. + +To illustrate: + +> struct :: Struct '[ "field1" ':-> Float, "field2" ':-> V 3 Float ] +> struct = 1.0 :& V3 0.0 1.0 0.0 :& End + +This defines a struct with two fields: + + * first field named @"field1"@, of type @Float@, + * second field named @"field2"@, of type @V 3 Float@. + +Note that the field annotations need not be type-level literals. +For instance, when specifying memory layout of vertex input data, +one instead specifies location slots (see "FIR.Layout"): + +> inputData :: Struct '[ Slot 0 0 ':-> Float, Slot 0 3 ':-> V 3 Float ] + + +-} + +module FIR.Prim.Struct + ( Struct(End, (:&)) + , LocationSlot(..) + , ShowLocationSlot + , FieldKind(..) + , StructFieldKind(fieldKind) + , HasStructField(getStructField, setStructField) + , headS, tailS + , foldrStruct + , traverseStruct + , ASTStructFields(..) + ) + where + +-- base +import Data.Kind + ( Type ) +import Data.List + ( intercalate ) +import Data.Typeable + ( Typeable ) +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( Symbol, KnownSymbol, AppendSymbol ) +import GHC.TypeNats + ( Nat, KnownNat + , type (+), type(-), type (*) + , Mod, Div + ) + +-- fir +import Data.Product + ( HList(HNil,(:>)), IsProduct(..) ) +import Data.Type.List + ( type (:++:) ) +import Data.Type.Map + ( (:->)((:->)) ) +import Data.Type.Known + ( Demotable(Demote) + , Known(known), knownValue + ) +import Data.Type.POrd + ( POrd(Compare) + , PEnum(Succ, Pred, FromEnum, ToEnum) + ) +import Data.Type.String + ( ShowNat ) +import FIR.AST.Type + ( AugType(Val) ) +import Math.Algebra.GradedSemigroup + ( GradedSemigroup(..) ) +import {-# SOURCE #-} FIR.Prim.Types + ( PrimTy + , PrimTyMap(primTyMapSing) + , SPrimTyMap(SNil, SCons) + ) + +------------------------------------------------------------ +-- structs + +infixr 4 :& +-- order *matters* for structs (memory layout!) +data Struct :: [fld :-> Type] -> Type where + End :: Struct '[] + (:&) :: forall k a as. a -> Struct as -> Struct ((k ':-> a) ': as) + +headS :: Struct ((k ':-> a) ': as) -> a +headS (a :& _) = a + +tailS :: Struct ((k ':-> a) ': as) -> Struct as +tailS (_ :& as) = as + +data LocationSlot n where + LocationSlot :: n -> n -> LocationSlot n + +deriving stock instance Show n => Show (LocationSlot n) + +type family ShowLocationSlot ( slot :: LocationSlot Nat ) :: Symbol where + ShowLocationSlot ('LocationSlot l c) + = "Location " `AppendSymbol` ShowNat l `AppendSymbol` ", Component " `AppendSymbol` ShowNat c + +data FieldKind (fld :: Type) where + NamedField :: FieldKind Symbol + LocationField :: FieldKind (LocationSlot Nat) + OtherField :: FieldKind fld + +class (Show (Demote fld), Typeable fld) => StructFieldKind fld where + fieldKind :: FieldKind fld +instance StructFieldKind Symbol where + fieldKind = NamedField +instance StructFieldKind (LocationSlot Nat) where + fieldKind = LocationField +instance {-# OVERLAPPABLE #-} (Show (Demote fld), Typeable fld) => StructFieldKind fld where + fieldKind = OtherField + +class HasStructField k a as | k as -> a where + getStructField :: Struct as -> a + setStructField :: a -> Struct as -> Struct as +instance {-# OVERLAPPING #-} + forall fld (k :: fld) (a :: Type) (as :: [ fld :-> Type ]) + . HasStructField k a ((k ':-> a) ': as) + where + getStructField = headS + setStructField b ( _ :& as ) = b :& as +instance forall fld (k :: fld) (a :: Type) (l :: fld) (x :: Type) (as :: [ fld :-> Type ]) + . HasStructField k a as + => HasStructField k a ((l ':-> x) ': as) + where + getStructField = getStructField @k @a @as . tailS + setStructField b ( a :& as ) = a :& setStructField @k @a @as b as +instance {-# OVERLAPPING #-} + forall fld (k :: fld) (a :: Type) (as :: [ fld :-> Type ]) + . HasStructField (0 :: Nat) a ((k ':-> a) ': as) + where + getStructField = headS + setStructField b ( _ :& as ) = b :& as +instance forall fld (l :: fld) (i :: Nat) (a :: Type) (x :: Type) (as :: [ fld :-> Type]) + . HasStructField (i-1) a as + => HasStructField i a ((l ':-> x) ': as) + where + getStructField = getStructField @(i-1) @a @as . tailS + setStructField b ( a :& as ) = a :& setStructField @(i-1) @a @as b as + +instance PrimTyMap as => Eq (Struct as) where + s1 == s2 = case primTyMapSing @_ @as of + SNil -> True + SCons -> + case (s1, s2) of + (a :& as, b :& bs) -> + a == b && as == bs + +instance PrimTyMap as => Ord (Struct as) where + compare s1 s2 = case primTyMapSing @_ @as of + SNil -> EQ + SCons -> + case (s1, s2) of + (a :& as, b :& bs) -> + case compare a b of + EQ -> compare as bs + un -> un + +display :: forall fld (as :: [fld :-> Type]) + . ( StructFieldKind fld, PrimTyMap as ) + => Struct as -> [String] +display s = case primTyMapSing @_ @as of + SNil -> [] + sCons@SCons -> + case sCons of + ( _ :: SPrimTyMap ((k ':-> a) ': xs) ) -> + case s of + (a :& as) -> + ( show (knownValue @k) ++ " :-> " ++ show a ) + : display as + +instance forall fld (as :: [fld :-> Type]) + . ( StructFieldKind fld, PrimTyMap as ) + => Show (Struct as) where + show s = "{ " ++ intercalate ", " (display s) ++ " }" + +instance IsProduct (Struct '[]) '[] where + fromHList _ = End + toHList _ = HNil + +instance IsProduct (Struct as) tys => IsProduct (Struct ((fld ':-> ty) ': as)) (ty ': tys) where + fromHList (a :> as) = a :& fromHList as + toHList (a :& as) = a :> toHList as + +instance GradedSemigroup (Struct :: [ fld :-> Type ] -> Type) [fld :-> Type] where + type Grade [fld :-> Type] (Struct :: [ fld :-> Type ] -> Type) as = Struct as + type as :: bs = as :++: bs + () :: Struct as -> Struct bs -> Struct (as :++: bs) + End t = t + (a :& s) t = a :& ( s t ) + +foldrStruct + :: forall as b. PrimTyMap as + => ( forall a. PrimTy a => a -> b -> b ) + -> b -> Struct as -> b +foldrStruct f b s = + case primTyMapSing @_ @as of + SNil + -> b + SCons {} + -> case s of + (a :& as) + -> f a (foldrStruct f b as) + +traverseStruct + :: ( Applicative f, PrimTyMap as ) + => ( forall a. PrimTy a => a -> f b ) + -> Struct as + -> f [b] +traverseStruct f + = foldrStruct ( \a bs -> liftA2 (:) (f a) bs ) + ( pure [] ) + +class Typeable bs => + ASTStructFields + ( ast :: ( AugType -> Type ) ) + ( as :: [ Symbol :-> Type ] ) + ( bs :: [ Symbol :-> Type ] ) + | as -> bs, bs ast -> as where + traverseStructASTs + :: forall f b. Applicative f + => ( forall a. ast (Val a) -> f b ) -> Struct as -> f [b] +instance ASTStructFields ast '[] '[] where + traverseStructASTs _ _ = pure [] +instance (KnownSymbol k2, k1 ~ k2, a ~ ast (Val b), Typeable b, ASTStructFields ast as bs) + => ASTStructFields ast ( (k1 ':-> a) ': as) ( (k2 ':-> b) ': bs) where + traverseStructASTs f (a :& as) = (:) <$> f a <*> traverseStructASTs f as + +----------------------------------------------------------- +-- instances for 'LocationSlot' + +instance Demotable (LocationSlot Nat) where + type Demote (LocationSlot Nat) = LocationSlot Word32 + +instance (KnownNat l, KnownNat c) => Known (LocationSlot Nat) ('LocationSlot l c) where + known = LocationSlot (knownValue @l) (knownValue @c) + +instance POrd (LocationSlot Nat) where + type Compare ('LocationSlot l1 c1) ('LocationSlot l2 c2) + = Compare '(l1, c1) '(l2, c2) -- lexicographic ordering + +type family SuccLocationSlot (slot :: LocationSlot Nat) :: LocationSlot Nat where + SuccLocationSlot ('LocationSlot l 3) = 'LocationSlot (l+1) 0 + SuccLocationSlot ('LocationSlot l c) = 'LocationSlot l (c+1) + +type family PredLocationSlot (slot :: LocationSlot Nat) :: LocationSlot Nat where + PredLocationSlot ('LocationSlot 0 0) = 'LocationSlot 0 0 + PredLocationSlot ('LocationSlot l 0) = 'LocationSlot (l-1) 3 + PredLocationSlot ('LocationSlot l c) = 'LocationSlot l (c-1) + +instance PEnum (LocationSlot Nat) where + type Succ loc = SuccLocationSlot loc + type Pred loc = PredLocationSlot loc + type FromEnum ('LocationSlot l c) + = 4 * l + c + type ToEnum n + = 'LocationSlot (n `Div` 4) (n `Mod` 4) diff --git a/src/FIR/Prim/Struct.hs-boot b/src/FIR/Prim/Struct.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/Prim/Struct.hs-boot @@ -0,0 +1,67 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module FIR.Prim.Struct where + +-- base +import Data.Kind + ( Type ) +import Data.Typeable + ( Typeable ) +import GHC.TypeLits + ( Symbol ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.Known + ( Demote ) +import Data.Type.Map + ( (:->) ) +import FIR.AST.Type + ( AugType(Val) ) + +------------------------------------------------------------ +-- structs + +data Struct :: [fld :-> Type] -> Type where +type role Struct nominal + +data LocationSlot n where + LocationSlot :: n -> n -> LocationSlot n + +instance Show n => Show (LocationSlot n) where + +data FieldKind (fld :: Type) where + NamedField :: FieldKind Symbol + LocationField :: FieldKind (LocationSlot Nat) + OtherField :: FieldKind fld + +class (Show (Demote fld), Typeable fld) => StructFieldKind fld where + fieldKind :: FieldKind fld + +instance StructFieldKind Symbol where +instance StructFieldKind (LocationSlot Nat) where +instance {-# OVERLAPPABLE #-} (Show (Demote fld), Typeable fld) => StructFieldKind fld where + +class Typeable bs => + ASTStructFields + ( ast :: ( AugType -> Type ) ) + ( as :: [ Symbol :-> Type ] ) + ( bs :: [ Symbol :-> Type ] ) + | as -> bs, bs ast -> as where + traverseStructASTs + :: forall f b. Applicative f + => ( forall a. ast (Val a) -> f b ) -> Struct as -> f [b] diff --git a/src/FIR/Prim/Types.hs b/src/FIR/Prim/Types.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Prim/Types.hs @@ -0,0 +1,728 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +--{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Prim.Types + +This module defines the types used internally, including singletons machinery that is necessary for code generation. + +See for instance 'CodeGen.IDs.constID' for a crucial application of these singletons. + +For situations where we only need one-way reification, i.e. being able to turn type-level data into value-level data +without the need to be able to go back the other way, see "Data.Type.Known". + +-} + +module FIR.Prim.Types where + +-- base +import Data.Int + ( Int8, Int16, Int32, Int64 ) +import Data.Kind + ( Type ) +import Data.List + ( intercalate ) +import Data.Proxy + ( Proxy(Proxy) ) +import Data.Type.Bool + ( type (&&) ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import Data.Type.List + ( type (:++:) ) +import Data.Typeable + ( Typeable, eqT ) +import Data.Word + ( Word8, Word16, Word32, Word64 ) +import GHC.TypeLits + ( Symbol, KnownSymbol + , TypeError, ErrorMessage(Text, ShowType, (:$$:), (:<>:)) + ) +import GHC.TypeNats + ( Nat, KnownNat, natVal + , type (+) + ) + +-- half +import Numeric.Half + ( Half ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- fir +import {-# SOURCE #-} Control.Type.Optic + ( IndexChain, IndexInfo(ThisIndex, AnyIndex) ) +import Data.Binary.Class.Put + ( Put ) +import Data.Constraint.All + ( All(allDict), AllDict(NilDict, ConsDict) ) +import Data.Function.Variadic + ( ListVariadic ) +import Data.Type.Known + ( Known, knownValue ) +import Data.Type.Map + ( (:->)((:->)) ) +import {-# SOURCE #-} FIR.AST + ( Syntactic(Internal) ) +import FIR.AST.Type + ( AugType(Val) ) +import FIR.Binding + ( Binding, BindingsMap, Var + , Permission(Read,Write), Permissions + ) +import FIR.Prim.Array + ( Array, RuntimeArray ) +import {-# SOURCE #-} FIR.Prim.Image + ( Image ) +import FIR.Prim.RayTracing + ( AccelerationStructure, RayQuery ) +import FIR.Prim.Struct + ( Struct, FieldKind(NamedField), StructFieldKind(fieldKind) ) +import Math.Algebra.Class + ( Ring ) +import Math.Linear + ( V, M ) +import qualified SPIRV.PrimTy as SPIRV +import SPIRV.ScalarTy + ( Signedness(Unsigned, Signed) + , Width(W8,W16,W32,W64) + ) +import qualified SPIRV.ScalarTy as SPIRV +import qualified SPIRV.Storage as SPIRV + ( StorageClass ) +import qualified SPIRV.Storage as Storage + +------------------------------------------------------------ +-- singletons for primitive types +-- this allows us to pattern match on the type when necessary + +data SScalarTy :: Type -> Type where + SWord8 :: SScalarTy Word8 + SWord16 :: SScalarTy Word16 + SWord32 :: SScalarTy Word32 + SWord64 :: SScalarTy Word64 + SInt8 :: SScalarTy Int8 + SInt16 :: SScalarTy Int16 + SInt32 :: SScalarTy Int32 + SInt64 :: SScalarTy Int64 + SHalf :: SScalarTy Half + SFloat :: SScalarTy Float + SDouble :: SScalarTy Double + +showSScalarTy :: SScalarTy ty -> String +showSScalarTy SWord8 = "Word8" +showSScalarTy SWord16 = "Word16" +showSScalarTy SWord32 = "Word32" +showSScalarTy SWord64 = "Word64" +showSScalarTy SInt8 = "Int8" +showSScalarTy SInt16 = "Int16" +showSScalarTy SInt32 = "Int32" +showSScalarTy SInt64 = "Int64" +showSScalarTy SHalf = "Half" +showSScalarTy SFloat = "Float" +showSScalarTy SDouble = "Double" + +type ScalarFromTy (ty :: Type) + = ( ScalarFromSScalar ( ScalarTySing ty ) :: SPIRV.ScalarTy ) + +type ScalarFromSScalar :: SScalarTy ty -> SPIRV.ScalarTy +type family ScalarFromSScalar sTy where + ScalarFromSScalar SWord8 = SPIRV.Integer Unsigned W8 + ScalarFromSScalar SWord16 = SPIRV.Integer Unsigned W16 + ScalarFromSScalar SWord32 = SPIRV.Integer Unsigned W32 + ScalarFromSScalar SWord64 = SPIRV.Integer Unsigned W64 + ScalarFromSScalar SInt8 = SPIRV.Integer Signed W8 + ScalarFromSScalar SInt16 = SPIRV.Integer Signed W16 + ScalarFromSScalar SInt32 = SPIRV.Integer Signed W32 + ScalarFromSScalar SInt64 = SPIRV.Integer Signed W64 + ScalarFromSScalar SHalf = SPIRV.Floating W16 + ScalarFromSScalar SFloat = SPIRV.Floating W32 + ScalarFromSScalar SDouble = SPIRV.Floating W64 + +type family TypeFromScalar ( scalar :: SPIRV.ScalarTy ) :: Type where + TypeFromScalar (SPIRV.Integer Unsigned W8 ) = Word8 + TypeFromScalar (SPIRV.Integer Unsigned W16) = Word16 + TypeFromScalar (SPIRV.Integer Unsigned W32) = Word32 + TypeFromScalar (SPIRV.Integer Unsigned W64) = Word64 + TypeFromScalar (SPIRV.Integer Signed W8 ) = Int8 + TypeFromScalar (SPIRV.Integer Signed W16) = Int16 + TypeFromScalar (SPIRV.Integer Signed W32) = Int32 + TypeFromScalar (SPIRV.Integer Signed W64) = Int64 + TypeFromScalar (SPIRV.Floating W16) = Half + TypeFromScalar (SPIRV.Floating W32) = Float + TypeFromScalar (SPIRV.Floating W64) = Double + +type family ScalarWidth (sTy :: SScalarTy ty) :: Nat where + ScalarWidth sTy + = SPIRV.WidthToNat + ( SPIRV.ScalarWidth ( ScalarFromSScalar sTy ) ) + +-- singleton data type +data SPrimTy :: Type -> Type where + SUnit :: SPrimTy () + SBool :: SPrimTy Bool + SScalar :: ScalarTy a => SPrimTy a + SVector :: (KnownNat n, PrimTy a) + => SPrimTy (V n a) + SMatrix :: (KnownNat m, KnownNat n, ScalarTy a, Ring a) + => SPrimTy (M m n a) + SArray :: (KnownNat n, PrimTy a) + => SPrimTy (Array n a) + SRuntimeArray + :: PrimTy a + => SPrimTy (RuntimeArray a) + SStruct :: forall (fld :: Type) (as :: [fld :-> Type]) + . ( StructFieldKind fld, PrimTyMap as ) + => SPrimTy (Struct as) + SAccelerationStructure + :: SPrimTy AccelerationStructure + +data SPrimTyMap :: [fld :-> Type] -> Type where + SNil :: SPrimTyMap '[] + SCons :: (StructFieldKind fld, Known fld k, PrimTy a, PrimTyMap as) + => SPrimTyMap ((k ':-> a) ': as) + +type family HasOpaqueType (a :: Type) :: Bool where + HasOpaqueType (Image _) = True + HasOpaqueType AccelerationStructure = True + HasOpaqueType RayQuery = True + HasOpaqueType (RuntimeArray _) = True + HasOpaqueType (Array _ a) = HasOpaqueType a + HasOpaqueType (Struct ((_ ':-> a) ': as )) = HasOpaqueType a && HasOpaqueType (Struct as) + HasOpaqueType _ = False + +instance Show (SPrimTy ty) where + show :: SPrimTy ty -> String + show SUnit = "()" + show SBool = "Bool" + show (SScalar :: SPrimTy a) = showSScalarTy (scalarTySing @a) + show sVector@SVector + = case sVector of + ( _ :: SPrimTy (V n a) ) -> + "V " ++ show (natVal (Proxy @n)) ++ " " ++ show (primTySing @a) + show sMatrix@SMatrix + = case sMatrix of + ( _ :: SPrimTy (M m n a) ) -> + "M " ++ show (natVal (Proxy @m)) ++ " " + ++ show (natVal (Proxy @n)) + ++ " " ++ showSScalarTy (scalarTySing @a) + show sArray@SArray + = case sArray of + ( _ :: SPrimTy (Array n a) ) -> + "Array " ++ show (natVal (Proxy @n)) + ++ " " ++ show (primTySing @a) + show sRuntimeArray@SRuntimeArray + = case sRuntimeArray of + ( _ :: SPrimTy (RuntimeArray a) ) -> + "RuntimeArray " ++ show (primTySing @a) + show sStruct@SStruct + = case sStruct of + ( _ :: SPrimTy (Struct as) ) -> + "Struct '[" + ++ intercalate ", " ( showSPrimTyMap ( primTyMapSing @_ @as ) ) + ++ "]" + show SAccelerationStructure = "AccelerationStructure" + +showSPrimTyMap :: SPrimTyMap as -> [String] +showSPrimTyMap SNil = [] +showSPrimTyMap sCons@SCons + = case sCons of + ( _ :: SPrimTyMap ((k ':-> a) ': as) ) -> + ( show (knownValue @k) ++ " :-> " ++ show ( primTySing @a ) ) + : showSPrimTyMap ( primTyMapSing @_ @as ) + +-- singleton data kind, without unpromotable contexts +data SKPrimTy :: Type -> Type where + SKUnit :: SKPrimTy () + SKBool :: SKPrimTy Bool + SKScalar :: SScalarTy a -> SKPrimTy a + SKVector :: SScalarTy a -> SKPrimTy (V n a) + SKMatrix :: SScalarTy a -> SKPrimTy (M m n a) + SKArray :: SKPrimTy a -> SKPrimTy (Array n a) + SKRuntimeArray + :: SKPrimTy a -> SKPrimTy (RuntimeArray a) + SKStruct :: SKPrimTyMap as -> SKPrimTy (Struct as) + SKAccelerationStructure :: SKPrimTy AccelerationStructure + +data SKPrimTyMap :: [fld :-> Type] -> Type where + SKNil :: SKPrimTyMap '[] + SKCons :: SKPrimTy a -> SKPrimTyMap as -> SKPrimTyMap ((k ':-> a) ': as) + +type ScalarTySing :: forall (ty :: Type) -> SScalarTy ty +type family ScalarTySing (ty :: Type) :: SScalarTy ty where + ScalarTySing Word8 = SWord8 + ScalarTySing Word16 = SWord16 + ScalarTySing Word32 = SWord32 + ScalarTySing Word64 = SWord64 + ScalarTySing Int8 = SInt8 + ScalarTySing Int16 = SInt16 + ScalarTySing Int32 = SInt32 + ScalarTySing Int64 = SInt64 + ScalarTySing Half = SHalf + ScalarTySing Float = SFloat + ScalarTySing Double = SDouble + ScalarTySing a + = TypeError + ( Text "Type " :<>: ShowType a :<>: Text " is not a valid scalar type." ) + +type PrimTySing :: forall (ty :: Type) -> SKPrimTy ty +type family PrimTySing (ty :: Type) :: SKPrimTy ty where + PrimTySing () = SKUnit + PrimTySing Bool = SKBool + PrimTySing Word8 = SKScalar SWord8 + PrimTySing Word16 = SKScalar SWord16 + PrimTySing Word32 = SKScalar SWord32 + PrimTySing Word64 = SKScalar SWord64 + PrimTySing Int8 = SKScalar SInt8 + PrimTySing Int16 = SKScalar SInt16 + PrimTySing Int32 = SKScalar SInt32 + PrimTySing Int64 = SKScalar SInt64 + PrimTySing Half = SKScalar SHalf + PrimTySing Float = SKScalar SFloat + PrimTySing Double = SKScalar SDouble + PrimTySing (V n a) = SKVector (ScalarTySing a) + PrimTySing (M m n a) = SKMatrix (ScalarTySing a) + PrimTySing (Array n a) = SKArray (PrimTySing a) + PrimTySing (RuntimeArray a) = SKRuntimeArray (PrimTySing a) + PrimTySing (Struct as) = SKStruct (MapPrimTySing as) + PrimTySing AccelerationStructure = SKAccelerationStructure + PrimTySing ty + = TypeError + ( Text "Type " :<>: ShowType ty :<>: Text " is not a valid primitive type." ) + +type MapPrimTySing :: forall fld. forall (as :: [fld :-> Type]) -> SKPrimTyMap as +type family MapPrimTySing as where + MapPrimTySing '[] = SKNil + MapPrimTySing ( ( k ':-> a) ': as) + = SKCons (PrimTySing a) (MapPrimTySing as) + +------------------------------------------------ + +class ( Show ty -- for convenience + , Eq ty, Ord ty, Typeable ty -- to keep track of lists of constants + , ty ~ ListVariadic '[] ty -- ty is not a function type + ) + => PrimTy ty where + -- associated type used for computing overlap with "OfType" optic + type FieldsOfType ty fldTy :: [ IndexChain ] + primTySing :: SPrimTy ty + +class ( PrimTy ty + , Put ty -- for serialisation + , HasOpaqueType ty ~ False + ) => ScalarTy ty where + scalarTySing :: SScalarTy ty + +type family MonolithicFields (a :: Type) (ty :: Type) :: [ IndexChain ] where + MonolithicFields a a = '[ '[] ] + MonolithicFields _ _ = '[] + +instance PrimTy () where + type FieldsOfType () _ = '[] + primTySing = SUnit +instance PrimTy Bool where + type FieldsOfType Bool a = MonolithicFields Bool a + primTySing = SBool +instance PrimTy AccelerationStructure where + type FieldsOfType AccelerationStructure a = MonolithicFields AccelerationStructure a + primTySing = SAccelerationStructure + +instance ScalarTy Word8 where + scalarTySing = SWord8 +instance ScalarTy Word16 where + scalarTySing = SWord16 +instance ScalarTy Word32 where + scalarTySing = SWord32 +instance ScalarTy Word64 where + scalarTySing = SWord64 +instance ScalarTy Int8 where + scalarTySing = SInt8 +instance ScalarTy Int16 where + scalarTySing = SInt16 +instance ScalarTy Int32 where + scalarTySing = SInt32 +instance ScalarTy Int64 where + scalarTySing = SInt64 +instance ScalarTy Half where + scalarTySing = SHalf +instance ScalarTy Float where + scalarTySing = SFloat +instance ScalarTy Double where + scalarTySing = SDouble + +class (ScalarTy ty, Integral ty) => IntegralTy ty where +instance IntegralTy Word8 where +instance IntegralTy Word16 where +instance IntegralTy Word32 where +instance IntegralTy Word64 where +instance IntegralTy Int8 where +instance IntegralTy Int16 where +instance IntegralTy Int32 where +instance IntegralTy Int64 where + +instance PrimTy Word8 where + type FieldsOfType Word8 a = MonolithicFields Word8 a + primTySing = SScalar +instance PrimTy Word16 where + type FieldsOfType Word16 a = MonolithicFields Word16 a + primTySing = SScalar +instance PrimTy Word32 where + type FieldsOfType Word32 a = MonolithicFields Word32 a + primTySing = SScalar +instance PrimTy Word64 where + type FieldsOfType Word64 a = MonolithicFields Word64 a + primTySing = SScalar +instance PrimTy Int8 where + type FieldsOfType Int8 a = MonolithicFields Int8 a + primTySing = SScalar +instance PrimTy Int16 where + type FieldsOfType Int16 a = MonolithicFields Int16 a + primTySing = SScalar +instance PrimTy Int32 where + type FieldsOfType Int32 a = MonolithicFields Int32 a + primTySing = SScalar +instance PrimTy Int64 where + type FieldsOfType Int64 a = MonolithicFields Int64 a + primTySing = SScalar +instance PrimTy Half where + type FieldsOfType Half a = MonolithicFields Half a + primTySing = SScalar +instance PrimTy Float where + type FieldsOfType Float a = MonolithicFields Float a + primTySing = SScalar +instance PrimTy Double where + type FieldsOfType Double a = MonolithicFields Double a + primTySing = SScalar + + +instance ( TypeError + ( Text "Use a specific width unsigned integer type \ + \instead of 'Word' (recommended: 'Word32')." + ) + , Put Word + ) + => PrimTy Word where + type FieldsOfType Word a = MonolithicFields Word a + primTySing = error "unreachable" +instance ( TypeError + ( Text "Use a specific width signed integer type \ + \instead of 'Int' (recommended: 'Int32')." + ) + , Put Int + ) + => PrimTy Int where + type FieldsOfType Int a = MonolithicFields Int a + primTySing = error "unreachable" +instance ( TypeError + ( Text "Use a specific width unsigned integer type \ + \instead of 'Word' (recommended: 'Word32')." + ) + , Put Word + ) + => ScalarTy Word where + scalarTySing = error "unreachable" +instance ( TypeError + ( Text "Use a specific width signed integer type \ + \instead of 'Int' (recommended: 'Int32')." + ) + , Put Int + ) + => ScalarTy Int where + scalarTySing = error "unreachable" + + +type family HomogeneousFields (c :: Type -> Type) (a :: Type) (b :: Type) :: [ IndexChain ] where + HomogeneousFields c a (c a) = '[ '[] ] + HomogeneousFields _ a b = MapCons AnyIndex ( FieldsOfType a b ) + +type family MapCons (x :: k) (xss :: [[k]]) :: [[k]] where + MapCons _ '[] = '[] + MapCons x (ys ': yss) = ( x ': ys ) ': MapCons x yss + +instance ( PrimTy a + , KnownNat n + ) => PrimTy (V n a) where + type FieldsOfType (V n a) ty = HomogeneousFields (V n) a ty + primTySing = SVector + +type family MatrixFields (m :: Nat) (a :: Type) (b :: Type) :: [ IndexChain ] where + MatrixFields m a (V m a) = '[ '[ AnyIndex ] ] + MatrixFields _ a a = '[ '[ AnyIndex, AnyIndex ] ] + MatrixFields _ _ _ = '[] -- no need to recurse as matrices can only contain scalars + +instance ( PrimTy a, ScalarTy a + , Ring a + , KnownNat m--, 2 <= m, m <= 4 + , KnownNat n--, 2 <= n, n <= 4 + ) => PrimTy (M m n a) where + type FieldsOfType (M m n a) ty = MatrixFields m a ty + primTySing = SMatrix + +instance (PrimTy a, KnownNat l) => PrimTy (Array l a) where + type FieldsOfType (Array l a) ty = HomogeneousFields (Array l) a ty + primTySing = SArray + +instance PrimTy a => PrimTy (RuntimeArray a) where + type FieldsOfType (RuntimeArray a) ty = HomogeneousFields RuntimeArray a ty + primTySing = SRuntimeArray + +class (Typeable as, StructFieldKind fld) => PrimTyMap (as :: [fld :-> Type]) where + primTyMapSing :: SPrimTyMap as + +instance StructFieldKind fld => PrimTyMap ('[] :: [fld :-> Type]) where + primTyMapSing = SNil + +instance forall ( fld :: Type ) + ( k :: fld ) + ( a :: Type ) + ( as :: [fld :-> Type] ) + . ( StructFieldKind fld + , Typeable k + , Known fld k + , PrimTy a + , PrimTyMap as + ) + => PrimTyMap ((k ':-> a) ': as) where + primTyMapSing = SCons + +instance PrimTyMap as => PrimTy (Struct (as :: [fld :-> Type])) where + type FieldsOfType (Struct as) ty = StructFieldsStartingAt 0 as ty + primTySing = SStruct + +type family StructFieldsStartingAt + ( i :: Nat ) + ( as :: [ fld :-> Type ] ) + ( ty :: Type ) + :: [ IndexChain ] + where + StructFieldsStartingAt _ '[] _ + = '[] + StructFieldsStartingAt i ( ( _ ':-> a ) ': as ) ty + = ( MapCons ( ThisIndex i ) (FieldsOfType a ty) ) + :++: + StructFieldsStartingAt (i+1) as ty + +primTy :: forall ty. PrimTy ty => SPIRV.PrimTy +primTy = sPrimTy ( primTySing @ty ) + +primTys :: forall as. All PrimTy as => [SPIRV.PrimTy] +primTys = case allDict @PrimTy @as of + NilDict -> [] + consDict@ConsDict -> + case consDict of + ( _ :: AllDict PrimTy (b ': bs) ) -> + primTy @b : primTys @bs + +primTyMap :: forall (fld :: Type) (flds :: [fld :-> Type]) + . PrimTyMap flds + => [ (Maybe ShortText, SPIRV.PrimTy) ] +primTyMap = sPrimTyMap ( primTyMapSing @fld @flds ) + +sPrimTy :: SPrimTy ty -> SPIRV.PrimTy +sPrimTy SUnit = SPIRV.Unit +sPrimTy SBool = SPIRV.Boolean +sPrimTy (SScalar :: SPrimTy a) + = SPIRV.Scalar (scalarTy @a) +sPrimTy vec@SVector = case vec of + ( _ :: SPrimTy (V n a) ) + -> SPIRV.Vector (knownValue @n) (primTy @a) +sPrimTy mat@SMatrix = case mat of + ( _ :: SPrimTy (M m n a) ) + -> SPIRV.Matrix (knownValue @m) (knownValue @n) (scalarTy @a) +sPrimTy arr@SArray = case arr of + ( _ :: SPrimTy (Array l a) ) + -> SPIRV.Array (knownValue @l) (primTy @a) +sPrimTy rtArr@SRuntimeArray = case rtArr of + ( _ :: SPrimTy (RuntimeArray a) ) + -> SPIRV.RuntimeArray (primTy @a) +sPrimTy struct@SStruct = case struct of + ( _ :: SPrimTy (Struct as) ) + -> SPIRV.Struct (sPrimTyMap (primTyMapSing @_ @as)) +sPrimTy SAccelerationStructure = SPIRV.AccelerationStructure + +sPrimTyMap :: forall (fld :: Type) (flds :: [fld :-> Type]) + . SPrimTyMap flds + -> [ (Maybe ShortText, SPIRV.PrimTy) ] +sPrimTyMap SNil = [] +sPrimTyMap cons@SCons = case cons of + ( _ :: SPrimTyMap (( f ':-> a ) ': as) ) + -> let + mbFieldName :: Maybe ShortText + mbFieldName = + case fieldKind @fld of + NamedField -> Just ( knownValue @f ) + _ -> Nothing + in ( mbFieldName, primTy @a ) + : sPrimTyMap (primTyMapSing @_ @as) + + +scalarTy :: forall ty. ScalarTy ty => SPIRV.ScalarTy +scalarTy = sScalarTy ( scalarTySing @ty ) + +sScalarTy :: SScalarTy ty -> SPIRV.ScalarTy +sScalarTy SWord8 = SPIRV.Integer Unsigned W8 +sScalarTy SWord16 = SPIRV.Integer Unsigned W16 +sScalarTy SWord32 = SPIRV.Integer Unsigned W32 +sScalarTy SWord64 = SPIRV.Integer Unsigned W64 +sScalarTy SInt8 = SPIRV.Integer Signed W8 +sScalarTy SInt16 = SPIRV.Integer Signed W16 +sScalarTy SInt32 = SPIRV.Integer Signed W32 +sScalarTy SInt64 = SPIRV.Integer Signed W64 +sScalarTy SHalf = SPIRV.Floating W16 +sScalarTy SFloat = SPIRV.Floating W32 +sScalarTy SDouble = SPIRV.Floating W64 + +------------------------------------------------------------ +-- statically known list of variables (for function definitions) + +class KnownVar (bd :: (Symbol :-> Binding)) where + knownVar :: ( ShortText, (SPIRV.PrimTy, Permissions) ) + +instance (KnownSymbol k, Known Permissions ps, PrimTy a) + => KnownVar (k ':-> Var ps a) where + knownVar = + ( knownValue @k + , ( primTy @a + , knownValue @ps + ) + ) + +class KnownVars (bds :: BindingsMap) where + knownVars :: [ (ShortText, (SPIRV.PrimTy, Permissions)) ] +instance KnownVars '[] where + knownVars = [] +instance (KnownVar bd, KnownVars bds) + => KnownVars (bd ': bds) where + knownVars = knownVar @bd : knownVars @bds + +------------------------------------------------------------ +-- statically known interfaces (for entry points) + +class KnownInterfaceBinding (bd :: (Symbol :-> Binding)) where + knownInterfaceBinding :: ( ShortText, (SPIRV.PrimTy, SPIRV.StorageClass) ) + +instance (KnownSymbol k, PrimTy a) + => KnownInterfaceBinding (k ':-> Var '[ 'Read ] a) where + knownInterfaceBinding + = ( knownValue @k + , ( primTy @a + , Storage.Input + ) + ) +instance (KnownSymbol k, PrimTy a) + => KnownInterfaceBinding (k ':-> Var '[ 'Write ] a) where + knownInterfaceBinding + = ( knownValue @k + , ( primTy @a + , Storage.Output + ) + ) + +instance + TypeError + ( Text "Interface binding " :<>: ShowType k :<>: Text " is both readable and writable." + :$$: Text "Interface variables must be of either 'Input' or 'Output' type, not both." ) + => KnownInterfaceBinding (k ':-> Var '[ 'Read, 'Write ] a) where + knownInterfaceBinding = error "unreachable" +instance + TypeError + ( Text "Interface binding " :<>: ShowType k :<>: Text " is both readable and writable." + :$$: Text "Interface variables must be of either 'Input' or 'Output' type, not both." ) + => KnownInterfaceBinding (k ':-> Var '[ 'Write, 'Read ] a) where + knownInterfaceBinding = error "unreachable" + +class KnownInterface (bds :: BindingsMap) where + knownInterface :: [ ( ShortText, (SPIRV.PrimTy, SPIRV.StorageClass) ) ] +instance KnownInterface '[] where + knownInterface = [] +instance (KnownInterfaceBinding bd, KnownInterface bds) + => KnownInterface (bd ': bds) where + knownInterface = knownInterfaceBinding @bd : knownInterface @bds + +------------------------------------------------------------ +-- functors + +type SPrimFunc :: (Type -> Type) -> Type +data SPrimFunc f where + SFuncVector :: KnownNat n => SPrimFunc (V n) + SFuncMatrix :: (KnownNat m, KnownNat n) => SPrimFunc (M m n) + SFuncArray :: KnownNat n => SPrimFunc (Array n) + +-- explicit dictionary passing workaround +-- would like to use a quantified constraint instead +-- (see (GHC issue #17226)[https://gitlab.haskell.org/ghc/ghc/issues/17226]) +type DistDict :: (Type -> Type) -> Type -> Type +data DistDict f a where + DistDict + :: ( Syntactic a, Internal a ~ Val va + , Syntactic (f a), Internal (f a) ~ Val (f va) + ) + => DistDict f a + +class ( Applicative f + --, forall a. (Syntactic a, Internal a ~ Val va, PrimTy va) => Syntactic (f a) + ) => PrimFunc f where + primFuncSing :: SPrimFunc f + distDict :: ( Syntactic a, Internal a ~ Val va, PrimTy va ) + => DistDict f a + +primFuncName :: forall f. PrimFunc f => String +primFuncName = case primFuncSing @f of + + sFuncVector@SFuncVector -> + case sFuncVector of + ( _ :: SPrimFunc (V n) ) -> + "V " ++ show (natVal (Proxy @n)) + + sFuncMatrix@SFuncMatrix -> + case sFuncMatrix of + ( _ :: SPrimFunc (M m n) ) -> + "M " ++ show (natVal (Proxy @m)) + ++ " " + ++ show (natVal (Proxy @n)) + sFuncArray@SFuncArray -> + case sFuncArray of + ( _ :: SPrimFunc (Array n) ) -> + "Array " ++ show (natVal (Proxy @n)) + +------------------------------------------------------------ +-- dependent pair + +data AConstant :: Type where + AConstant :: PrimTy ty => ty -> AConstant + +aConstant :: PrimTy ty => ty -> AConstant +aConstant = AConstant + +instance Show AConstant where + show (AConstant (a :: ty)) + = "Constant " ++ show a ++ " of type " ++ show (primTy @ty) + +instance Eq AConstant where + (AConstant (a1 :: ty1)) == (AConstant (a2 :: ty2)) + = case eqT @ty1 @ty2 of + Just Refl -> a1 == a2 + _ -> False + +instance Ord AConstant where + (AConstant (a1 :: ty1)) `compare` (AConstant (a2 :: ty2)) + = case eqT @ty1 @ty2 of + Just Refl -> compare a1 a2 + _ -> compare (primTy @ty1) + (primTy @ty2) diff --git a/src/FIR/Prim/Types.hs-boot b/src/FIR/Prim/Types.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/Prim/Types.hs-boot @@ -0,0 +1,117 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module FIR.Prim.Types where + +-- base +import Data.Kind + ( Type ) +import Data.Typeable + ( Typeable ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- fir +import {-# SOURCE #-} Control.Type.Optic + ( IndexChain ) +import Data.Binary.Class.Put + ( Put ) +import Data.Function.Variadic + ( ListVariadic ) +import Data.Type.Known + ( Known ) +import Data.Type.Map + ( (:->)((:->)) ) +import {-# SOURCE #-} FIR.AST +import FIR.AST.Type + ( AugType(Val) ) +import {-# SOURCE #-} FIR.Prim.Struct + ( StructFieldKind ) +import qualified SPIRV.PrimTy as SPIRV +import qualified SPIRV.ScalarTy as SPIRV + +------------------------------------------------------------ +-- singletons for primitive types + +data SScalarTy :: Type -> Type where +type role SScalarTy nominal + +data SPrimTy :: Type -> Type where +type role SPrimTy nominal + +type family HasOpaqueType (a :: Type) :: Bool where .. + +class ( Show ty + , Eq ty, Ord ty, Typeable ty + , ty ~ ListVariadic '[] ty + ) + => PrimTy ty where + type FieldsOfType ty fldTy :: [ IndexChain ] + primTySing :: SPrimTy ty + +class ( PrimTy ty + , Put ty + , HasOpaqueType ty ~ False + ) + => ScalarTy ty where + scalarTySing :: SScalarTy ty + +class (ScalarTy ty, Integral ty) => IntegralTy ty + +scalarTy :: forall ty. ScalarTy ty => SPIRV.ScalarTy +primTy :: forall ty. PrimTy ty => SPIRV.PrimTy + +data SPrimTyMap :: [fld :-> Type] -> Type where + SNil :: SPrimTyMap '[] + SCons :: (StructFieldKind fld, Known fld k, PrimTy a, PrimTyMap as) + => SPrimTyMap ((k ':-> a) ': as) +type role SPrimTyMap nominal + +class (Typeable as, StructFieldKind fld) => PrimTyMap (as :: [fld :-> Type]) where + primTyMapSing :: SPrimTyMap as + +primTyMap :: forall (fld :: Type) (flds :: [fld :-> Type]) + . PrimTyMap flds + => [ (Maybe ShortText, SPIRV.PrimTy) ] + +instance StructFieldKind fld => PrimTyMap ('[] :: [fld :-> Type]) where + +instance forall ( fld :: Type ) + ( k :: fld ) + ( a :: Type ) + ( as :: [fld :-> Type] ) + . ( StructFieldKind fld + , Typeable k + , Known fld k + , PrimTy a + , PrimTyMap as + ) + => PrimTyMap ((k ':-> a) ': as) where + + +type SPrimFunc :: (Type -> Type) -> Type +data SPrimFunc :: (Type -> Type) -> Type where +type role SPrimFunc nominal + +type DistDict :: (Type -> Type) -> Type -> Type +data DistDict f a where +type role DistDict nominal nominal + +class ( Applicative f + --, forall a. (Syntactic a, Internal a ~ Val va, PrimTy va) => Syntactic (f a) + ) => PrimFunc f where + primFuncSing :: SPrimFunc f + distDict :: ( Syntactic a, Internal a ~ Val va, PrimTy va ) + => DistDict f a + +primFuncName :: forall f. PrimFunc f => String diff --git a/src/FIR/ProgramState.hs b/src/FIR/ProgramState.hs new file mode 100644 --- /dev/null +++ b/src/FIR/ProgramState.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.ProgramState + +Defines the type-level data used for the state of the indexed monad used to construct programs: + +> program :: Program (i :: ProgramState) (j :: ProgramState) (a :: Type) + +See "FIR.Module.Program". + +The program state consists of: + + * the bindings that are in scope (such as built-in variables or user-defined variables), + * the function context (whether the current code is contained within a function/entry-point, or is at the top-level), + * information associated to the functions and entry-points relevant to the program, + such as whether they have been defined yet or only declared. + * the data of which SPIR-V backend we are using: Vulkan or OpenCL. +-} + +module FIR.ProgramState where + +-- base +import Data.Kind + ( Type ) +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( Symbol, KnownSymbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- fir +import Data.Type.Known + ( Demotable(Demote) + , Known(known), knownValue + ) +import Data.Type.Map + ( Map, (:->) ) +import FIR.Binding + ( BindingsMap + , Permissions + ) +import FIR.Prim.RayTracing + ( RayQueryState ) +import FIR.Prim.Types + ( KnownVars(knownVars) ) +import qualified SPIRV.Control as SPIRV +import qualified SPIRV.Decoration as SPIRV +import qualified SPIRV.PrimTy as SPIRV + ( PrimTy ) +import qualified SPIRV.Stage as SPIRV +import qualified SPIRV.Storage as SPIRV + +------------------------------------------------------------------- +-- | Data (kind) used to keep track of function context at the type-level. +data FunctionContext lit nat bindings mbIface where + TopLevel :: FunctionContext lit nat bindings iface + InFunction :: lit -> bindings -> FunctionContext lit nat bindings mbIface + InEntryPoint + :: lit + -> SPIRV.ExecutionInfo nat em + -> mbIface + -> FunctionContext lit nat bindings mbIface + +deriving stock instance ( Show lit, Show bindings, Show nat, Show mbIface ) + => Show ( FunctionContext lit nat bindings mbIface ) + + +type InterfaceVariable nat ty = ([SPIRV.Decoration nat], ty) +type TLInterfaceVariable = InterfaceVariable Nat Type +type VLInterfaceVariable = InterfaceVariable Word32 SPIRV.PrimTy + +type TLInterface + = [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] +type VLInterface + = [ SPIRV.StorageClass :-> [ ShortText :-> VLInterfaceVariable ] ] + +-- | A type-level function context. +type TLFunctionContext + = FunctionContext + Symbol + Nat + BindingsMap + ( Maybe TLInterface ) +-- | A value-level function context. +type VLFunctionContext + = FunctionContext + ShortText + Word32 + [ ( ShortText, (SPIRV.PrimTy, Permissions) ) ] + ( Maybe VLInterface ) + +instance Demotable TLFunctionContext where + type Demote TLFunctionContext = VLFunctionContext + +instance Known TLFunctionContext 'TopLevel where + known = TopLevel +instance ( KnownVars args + , KnownSymbol fnName + ) + => Known TLFunctionContext ('InFunction fnName args) where + known = InFunction + ( knownValue @fnName ) + ( knownVars @args ) +instance ( Known (SPIRV.ExecutionInfo Nat stage) stageInfo + , KnownSymbol stageName + ) + => Known TLFunctionContext + ( 'InEntryPoint + stageName + ( stageInfo :: SPIRV.ExecutionInfo Nat stage ) + ('Just iface) + ) where + known = InEntryPoint + ( knownValue @stageName ) + ( knownValue @stageInfo ) + Nothing + +data Definedness + = Declared + | Defined + +-- | Keeps track of a function at the type level. +data FunctionInfo where + FunctionInfo + :: BindingsMap + -> Type + -> SPIRV.FunctionControl + -> Definedness + -> FunctionInfo + +-- | Keeps track of an entry point at the type level: +-- +-- - a type level 'SPIRV.ExecutionInfo' recording the stage as well as additional +-- stage information, +-- - the entry point interface (input/output variables which it uses), +-- (or Nothing if the interface has not yet been computed). +data EntryPointInfo where + EntryPointInfo + :: SPIRV.ExecutionInfo Nat stage + -> TLInterface + -> Definedness + -> EntryPointInfo + +newtype CFGState = CFGState { loopDepth :: Nat } + +-- | State that is used in the user-facing indexed monad (at the type level). +-- Consists of: +-- +-- - a type-level list of which bindings are in scope, +-- such as user-defined functions, user-defined variables +-- and built-in variables, +-- - a context – whether code in the current indexed monadic state +-- occurs inside a function or entry-point body – +-- - the current control-flow state, +-- - which functions are to be declared, +-- whether they have been declared yet, +-- and some further information (arguments, function control), +-- - which entry points are to be declared, +-- whether they have been declared yet, together with +-- some additional info pertaining to their respective execution modes, +-- and their interfaces (user defined inputs/outputs), +-- - the state of all current ray-query operations, +-- - which SPIR-V backend is being used (Vulkan or OpenCL). +data ProgramState + = ProgramState + { bindings :: BindingsMap + , context :: TLFunctionContext + , cfgState :: CFGState + , functions :: Map Symbol FunctionInfo + , entryPoints :: Map Symbol EntryPointInfo + , interface :: TLInterface + , rayQueries :: Map Symbol RayQueryState + , backend :: SPIRV.Backend + } + +type family Bindings ( s :: ProgramState ) :: BindingsMap where + Bindings ('ProgramState bds _ _ _ _ _ _ _) = bds + +type family CFGInfo ( s :: ProgramState ) :: CFGState where + CFGInfo ('ProgramState _ _ cfg _ _ _ _ _) = cfg + +type family FunctionInfos ( s :: ProgramState ) :: Map Symbol FunctionInfo where + FunctionInfos ('ProgramState _ _ _ fs _ _ _ _) = fs + +type family EntryPointInfos ( s :: ProgramState ) :: Map Symbol EntryPointInfo where + EntryPointInfos ('ProgramState _ _ _ _ eps _ _ _) = eps + +type family ExecutionContext ( s :: ProgramState ) :: Maybe SPIRV.ExecutionModel where + ExecutionContext ('ProgramState _ ('InEntryPoint _ (info :: SPIRV.ExecutionInfo Nat stage) _) _ _ _ _ _ _) + = Just stage + ExecutionContext _ + = Nothing + +type family RayQueries ( s :: ProgramState ) :: Map Symbol RayQueryState where + RayQueries ('ProgramState _ _ _ _ _ _ rayQueries _) = rayQueries + +executionContext :: VLFunctionContext -> Maybe (ShortText, SPIRV.ExecutionModel) +executionContext (InEntryPoint stageName stageInfo _) = Just (stageName, SPIRV.modelOf stageInfo) +executionContext _ = Nothing + +type family ExecutionContext' ( s :: ProgramState ) :: SPIRV.ExecutionModel where + ExecutionContext' ('ProgramState _ ('InEntryPoint _ (info :: SPIRV.ExecutionInfo Nat stage) _) _ _ _ _ _ _) + = stage + ExecutionContext' _ + = TypeError + ( Text "Cannot access stage context: not within a stage." ) + +type family ExecutionInfoContext + ( s :: ProgramState ) + :: Maybe (SPIRV.ExecutionInfo Nat (ExecutionContext' s)) + where + ExecutionInfoContext ('ProgramState _ ('InEntryPoint _ info _) _ _ _ _ _ _) + = Just info + ExecutionInfoContext _ = 'Nothing diff --git a/src/FIR/ProgramState.hs-boot b/src/FIR/ProgramState.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/ProgramState.hs-boot @@ -0,0 +1,3 @@ +module FIR.ProgramState where + +data ProgramState diff --git a/src/FIR/Syntax/AST.hs b/src/FIR/Syntax/AST.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/AST.hs @@ -0,0 +1,1213 @@ +{-# OPTIONS_HADDOCK ignore-exports #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Syntax.AST + +This module, together with "FIR.Syntax.Program", +provides most of the user-facing syntax for constructing +and manipulating values in the EDSL. + +This is done through type class overloading, here in the form of +orphan instances for types of the form @AST a@ +(representing pure values in the EDSL). + +-} + +module FIR.Syntax.AST + ( -- switch statement + switch + + -- functor/applicative for AST values + , ASTApplicative(..), fmapAST, (<$$>) + + -- + orphan instances + ) + where + +-- base +import Prelude hiding + ( Eq(..), (&&), (||), not + , Ord(..) + , Num(..), Floating(..) + , Integral(..), floor + , Fractional(..), fromRational + , Floating(..) + , RealFloat(..) + , Functor(..), (<$>) + , Applicative(..) + ) +import qualified Prelude +import Data.Int + ( Int8, Int16, Int32, Int64 ) +import Data.Kind + ( Type, Constraint ) +import Data.Proxy + ( Proxy(Proxy) ) +import Data.Typeable + ( Typeable ) +import Data.Word + ( Word8, Word16, Word32, Word64 ) +import GHC.TypeLits + ( Symbol, KnownSymbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat, KnownNat + , type (+), CmpNat, sameNat + ) + +-- half +import Numeric.Half + ( Half ) + +-- vector-sized +import qualified Data.Vector.Sized as Vector + ( Vector, generate ) + +-- fir +import Control.Type.Optic + ( Optic(..), Index + , Gettable, ReifiedGetter(view) + , Settable, ReifiedSetter(set) + , ProductComponents(ProductO, EndProd_) + , ComponentsGettable + , ComponentsSettable + , ArePairwiseDisjoint + , Container(FieldIndexFromName) + ) +import Data.Constraint.All + ( All ) +import Data.Finite.With + ( withFinite ) +import Data.Function.Variadic + ( ListVariadic ) +import Data.Product + ( IsProduct + , AreProducts + , Distribute + , MapHList + ) +import Data.Type.List + ( KnownLength(sLength) + , SameLength + , type (:++:), Postpend, Snoc + ) +import Data.Type.Map + ( (:->)((:->)), Key ) +import FIR.AST + ( AST, Code + , Syntactic(Internal, toAST, fromAST) + , InternalType + , primOp + , pattern (:$), pattern Lit + , pattern Switch + , pattern View, pattern Set + , pattern Pure, pattern Ap + , pattern MkVector, pattern Mat, pattern UnMat, pattern Array, pattern Struct + , pattern GradedMappend + ) +import FIR.AST.Optics + ( AugListVariadic ) +import FIR.AST.Type + ( AugType(Val, (:-->)) + , FunArgs, FunRes + , ApplyFAug + ) +import FIR.Syntax.Optics + ( KnownOptic(opticSing) + , KnownComponents + , (%:.:) + , ValidAnIndexOptic + ) +import FIR.Prim.Array + ( Array(MkArray), RuntimeArray ) +import FIR.Prim.Op + ( PrimTyVal, Vectorise(Vectorise) ) +import FIR.Prim.Struct + ( Struct((:&), End) ) +import FIR.Prim.Types + ( PrimTy + , SScalarTy(..), ScalarTy, IntegralTy + , ScalarFromTy, TypeFromScalar + , SPrimFunc(..), PrimFunc(..), DistDict(DistDict) + , scalarTySing + ) +import FIR.Validation.Bounds + ( StructIndexFromName ) +import Math.Algebra.Class + ( AdditiveMonoid(..), CancellativeAdditiveMonoid(..), AdditiveGroup(..) + , Semiring(..), Ring + , DivisionRing(..) + , Signed(..), Archimedean(..) + , Floating(..), RealFloat(..) + , Integral, Unsigned + , Convert(..), Rounding(..) + ) +import Math.Algebra.GradedSemigroup + ( GradedSemigroup(..) ) +import Math.Linear + ( Semimodule(..), LinearModule(..) + , Inner(..), Cross(..) + , Matrix(..), VectorOf + , V, M(..) + , buildV + ) +import Math.Logic.Bits + ( Bits(..), BitShift(..), BitCast(..) ) +import Math.Logic.Class + ( Eq(..), Boolean(..), Ord(..) ) +import qualified SPIRV.ScalarTy as SPIRV +import qualified SPIRV.PrimOp as SPIRV + +-------------------------------------------------------------------------------------- +-- Instances for AST type + +-- * Logical operations +-- +-- $logical +-- Instances for: +-- +-- 'Boolean', +-- +-- 'Eq', 'Ord' (note: not the "Prelude" type classes). +-- +-- Note that rebindable syntax for if-then-else is provided +-- by the module "FIR.Syntax.IfThenElse". + +instance ( b ~ Bool ) => Boolean (Code b) where + true = Lit True + false = Lit False + (&&) = primOp @Bool @SPIRV.BoolAnd + (||) = primOp @Bool @SPIRV.BoolOr + not = primOp @Bool @SPIRV.BoolNot + +instance ( PrimTy a, Eq a, Logic a ~ Bool ) + => Eq (Code a) where + type Logic (Code a) = Code Bool + (==) = primOp @a @SPIRV.Equal + (/=) = primOp @a @SPIRV.NotEqual + +instance ( ScalarTy a, Ord a, Logic a ~ Bool ) + => Ord (Code a) where + (<=) = primOp @a @SPIRV.LTE + (>=) = primOp @a @SPIRV.GTE + (<) = primOp @a @SPIRV.LT + (>) = primOp @a @SPIRV.GT + min = primOp @a @SPIRV.Min + max = primOp @a @SPIRV.Max + +-- | Switch statement. +-- Takes a scrutinee, a list of cases and a default (fallthrough) case. +-- +-- Returns a switch statement which decides on the branch to follow by inspecting the scrutinee. +-- +-- See 'FIR.Syntax.Program.switchM' for a monadic version. +switch :: ( Syntactic scrut + , Internal scrut ~ Val vscrut + , IntegralTy vscrut + , Syntactic val + , Internal val ~ Val vval + , PrimTy vval + ) + => scrut -- ^ Scrutinee. + -> [ vscrut :-> val ] -- ^ Cases. + -> val -- ^ Default (fallthrough) case. + -> val +switch scrut cases val = fromAST $ Switch (toAST scrut) (toAST val) (map ( \ (x :-> y) -> (x, toAST y) ) cases) + +-- * Bitwise operations +-- +-- $bitwise +-- Instances for: +-- +-- 'Bits', 'BitShift' (note: not 'Data.Bits.Bits'), 'BitCast'. + +instance (ScalarTy a, Bits a) => Bits (Code a) where + (.&.) = primOp @a @SPIRV.BitAnd + (.|.) = primOp @a @SPIRV.BitOr + xor = primOp @a @SPIRV.BitXor + complement = primOp @a @SPIRV.BitNot + zeroBits = Lit ( zeroBits @a ) + bitReverse = primOp @a @SPIRV.ReverseBits + +instance (ScalarTy a, ScalarTy s, BitShift '(a,s)) + => BitShift '(Code a, Code s) where + shiftL = primOp @'(a,s) @SPIRV.BitShiftLeft + shiftR = primOp @'(a,s) @SPIRV.BitShiftRight + +instance (ScalarTy a, ScalarTy b, BitCast a b) + => BitCast (Code a) (Code b) where + bitcast = primOp @'(a,b) @SPIRV.CastOp + +-- * Numeric operations +-- +-- $numeric +-- Instances for: +-- +-- 'AdditiveMonoid', 'AdditiveGroup', 'Signed', +-- +-- 'Semiring', 'Ring', +-- +-- 'DivisionRing', 'Archimedean' (Archimedean ordered group), +-- +-- 'Floating', 'RealFloat' (note: not the "Prelude" type classes) +-- +-- 'Integral', 'Unsigned'. + +instance (ScalarTy a, AdditiveMonoid a) => AdditiveMonoid (Code a) where + (+) = primOp @a @SPIRV.Add + zero = Lit (zero :: a) + fromInteger = Lit . fromInteger +instance (ScalarTy a, Semiring a) => Semiring (Code a) where + (*) = primOp @a @SPIRV.Mul +instance (ScalarTy a, CancellativeAdditiveMonoid a) => CancellativeAdditiveMonoid (Code a) where + (-) = primOp @a @SPIRV.Sub +instance (ScalarTy a, AdditiveGroup a) => AdditiveGroup (Code a) where + negate = primOp @a @SPIRV.Neg +instance (ScalarTy a, Signed a) => Signed (Code a) where + abs = primOp @a @SPIRV.Abs + signum = primOp @a @SPIRV.Sign +instance (ScalarTy a, DivisionRing a) => DivisionRing (Code a) where + (/) = primOp @a @SPIRV.Div + fromRational = Lit . fromRational + +instance Archimedean (Code Word8 ) where + mod = primOp @Word8 @SPIRV.Mod + rem = primOp @Word8 @SPIRV.Rem + div = primOp @Word8 @SPIRV.Quot +instance Archimedean (Code Word16) where + mod = primOp @Word16 @SPIRV.Mod + rem = primOp @Word16 @SPIRV.Rem + div = primOp @Word16 @SPIRV.Quot +instance Archimedean (Code Word32) where + mod = primOp @Word32 @SPIRV.Mod + rem = primOp @Word32 @SPIRV.Rem + div = primOp @Word32 @SPIRV.Quot +instance Archimedean (Code Word64) where + mod = primOp @Word64 @SPIRV.Mod + rem = primOp @Word64 @SPIRV.Rem + div = primOp @Word64 @SPIRV.Quot +instance Archimedean (Code Int8 ) where + mod = primOp @Int8 @SPIRV.Mod + rem = primOp @Int8 @SPIRV.Rem + div = primOp @Int8 @SPIRV.Quot +instance Archimedean (Code Int16 ) where + mod = primOp @Int16 @SPIRV.Mod + rem = primOp @Int16 @SPIRV.Rem + div = primOp @Int16 @SPIRV.Quot +instance Archimedean (Code Int32 ) where + mod = primOp @Int32 @SPIRV.Mod + rem = primOp @Int32 @SPIRV.Rem + div = primOp @Int32 @SPIRV.Quot +instance Archimedean (Code Int64 ) where + mod = primOp @Int64 @SPIRV.Mod + rem = primOp @Int64 @SPIRV.Rem + div = primOp @Int64 @SPIRV.Quot +instance Archimedean (Code Half ) where + mod = primOp @Half @SPIRV.Mod + rem = primOp @Half @SPIRV.Rem + div a b = floor (a / b) +instance Archimedean (Code Float ) where + mod = primOp @Float @SPIRV.Mod + rem = primOp @Float @SPIRV.Rem + div a b = floor (a / b) +instance Archimedean (Code Double) where + mod = primOp @Double @SPIRV.Mod + rem = primOp @Double @SPIRV.Rem + div a b = floor (a / b) + +instance (ScalarTy a, Floating a) => Floating (Code a) where + pi = Lit pi + exp = primOp @a @SPIRV.FExp + log = primOp @a @SPIRV.FLog + sqrt = primOp @a @SPIRV.FSqrt + invSqrt = primOp @a @SPIRV.FInvSqrt + sin = primOp @a @SPIRV.FSin + cos = primOp @a @SPIRV.FCos + tan = primOp @a @SPIRV.FTan + asin = primOp @a @SPIRV.FAsin + acos = primOp @a @SPIRV.FAcos + atan = primOp @a @SPIRV.FAtan + sinh = primOp @a @SPIRV.FSinh + cosh = primOp @a @SPIRV.FCosh + tanh = primOp @a @SPIRV.FTanh + asinh = primOp @a @SPIRV.FAsinh + acosh = primOp @a @SPIRV.FAcosh + atanh = primOp @a @SPIRV.FAtanh + (**) = primOp @a @SPIRV.FPow + +instance (ScalarTy a, RealFloat a, Eq a, Logic a ~ Bool) => RealFloat (Code a) where + atan2 = primOp @a @SPIRV.FAtan2 + isNaN = primOp @a @SPIRV.FIsNaN + isInfinite = primOp @a @SPIRV.FIsInf + +instance (ScalarTy a, Integral a) => Integral (Code a) where +instance (ScalarTy a, Unsigned a) => Unsigned (Code a) where + +-- * Numeric conversions +-- +-- $conversions +-- Instance for 'Convert', 'Rounding'. + +-- Helpers to choose which conversion function to use. +-- * Can use identity function when @a ~ b@. +-- * For converting from different sign + different width integer types, +-- two operations are needed: resizing + bitcast. +-- The intermediate type is recorded. +data WhichConversion + = UseIdentity + | UseConversion + | UseConversionThenBitcast Type + +type family ChooseConversion (a :: Type) (b :: Type) :: WhichConversion where + ChooseConversion a a = UseIdentity + ChooseConversion a b = + ChooseConversionFromScalars + a ( ScalarFromTy a ) + b ( ScalarFromTy b ) + +type family ChooseConversionFromScalars + ( a :: Type ) ( sa :: SPIRV.ScalarTy ) + ( b :: Type ) ( sb :: SPIRV.ScalarTy ) + :: WhichConversion + where + ChooseConversionFromScalars + _ _ + _ ( SPIRV.Floating w ) + = UseConversion + ChooseConversionFromScalars + a ( SPIRV.Floating v ) + b _ + = TypeError + ( Text "Cannot convert from type " :<>: ShowType a + :$$: Text "to type " :<>: ShowType b + ) + ChooseConversionFromScalars + _ ( SPIRV.Integer s v ) + _ ( SPIRV.Integer s w ) + = UseConversion + ChooseConversionFromScalars + _ ( SPIRV.Integer r w ) + _ ( SPIRV.Integer s w ) + = UseConversion -- (strictly speaking this ends up being a bitcast) + ChooseConversionFromScalars + _ ( SPIRV.Integer r v ) + _ ( SPIRV.Integer s w ) + = UseConversionThenBitcast + ( TypeFromScalar ( SPIRV.Integer r w ) ) + +class DispatchConversion a b (useIdentity :: WhichConversion) where + conversion :: Code a -> Code b + +instance ScalarTy a => DispatchConversion a a UseIdentity where + conversion = id +instance (ScalarTy a, ScalarTy b, Convert '(a,b)) => DispatchConversion a b 'UseConversion where + conversion = primOp @'(a,b) @SPIRV.Convert +instance ( ScalarTy a, ScalarTy b, ScalarTy x + , Convert '(a,x), Convert '(x,b) + ) + => DispatchConversion a b ('UseConversionThenBitcast x) where + conversion + = ( primOp @'(x,b) @SPIRV.Convert :: Code x -> Code b ) + . ( primOp @'(a,x) @SPIRV.Convert :: Code a -> Code x ) + +instance ( ScalarTy a, ScalarTy b, DispatchConversion a b (ChooseConversion a b) ) + => Convert '(Code a, Code b) where + convert = conversion @a @b @(ChooseConversion a b) + +instance {-# OVERLAPPING #-} + ( ScalarTy a, Rounding '(a,a) ) + => Rounding '(Code a, Code a) where + truncate = primOp @'(a,a) @SPIRV.CTruncate + round = primOp @'(a,a) @SPIRV.CRound + floor = primOp @'(a,a) @SPIRV.CFloor + ceiling = primOp @'(a,a) @SPIRV.CCeiling + +instance ( ScalarTy a, ScalarTy b + , Floating a, Integral b + , Rounding '(a,a), Rounding '(a,b) + ) + => Rounding '(Code a, Code b) where + truncate = primOp @'(a,b) @SPIRV.CTruncate + round = primOp @'(a,b) @SPIRV.CTruncate @(Code a -> Code b) + . primOp @'(a,a) @SPIRV.CRound + floor = primOp @'(a,b) @SPIRV.CTruncate @(Code a -> Code b) + . primOp @'(a,a) @SPIRV.CFloor + ceiling = primOp @'(a,b) @SPIRV.CTruncate @(Code a -> Code b) + . primOp @'(a,a) @SPIRV.CCeiling + + +----------------------------------------------- +-- * Optics + +class KnownOptic optic => KnownASTOptic astoptic optic | astoptic -> optic where + +-- ** Simple instances + +-- *** Name + +instance ( empty ~ '[] + , KnownSymbol k + , r ~ Code a + , KnownOptic (Field_ k :: Optic '[] s a) + ) + => KnownASTOptic (Field_ k :: Optic empty1 (Code s) r) (Field_ k :: Optic '[] s a) + where +instance ( KnownSymbol k + , empty ~ '[] + , Gettable (Field_ k :: Optic '[] s a) + , r ~ Code a + ) + => Gettable (Field_ k :: Optic empty (Code s) r) + where +instance ( KnownSymbol k + , empty ~ '[] + , Gettable (Field_ k :: Optic '[] s a) + , ReifiedGetter (Field_ k :: Optic '[] s a) + , PrimTy a, PrimTy s + , KnownOptic (Field_ k :: Optic '[] s a) + , r ~ Code a + ) + => ReifiedGetter (Field_ k :: Optic empty (Code s) r) + where + view = fromAST + $ View + sLength + ( opticSing @(Field_ k :: Optic '[] s a) ) +instance ( KnownSymbol k + , empty ~ '[] + , Settable (Field_ k :: Optic '[] s a) + , r ~ Code a + ) + => Settable (Field_ k :: Optic empty (Code s) r) + where +instance ( KnownSymbol k + , empty ~ '[] + , Settable (Field_ k :: Optic '[] s a) + , ReifiedSetter (Field_ k :: Optic '[] s a) + , PrimTy s, PrimTy a + , KnownOptic (Field_ k :: Optic '[] s a) + , r ~ Code a + ) + => ReifiedSetter (Field_ k :: Optic empty (Code s) r) + where + set = fromAST + $ Set + sLength + ( opticSing @(Field_ k :: Optic '[] s a) ) + +-- *** Run-time index + +instance ( Integral ty, IntegralTy ty + , ix' ~ '[ Code ty ] + , r ~ Code a + , ValidAnIndexOptic '[ty] s a + , PrimTy s, PrimTy a + ) + => KnownASTOptic (RTOptic_ :: Optic ix' (Code s) r) (RTOptic_ :: Optic '[ty] s a) + where +instance ( Integral ty + , ix ~ '[Code ty] + , Gettable (RTOptic_ :: Optic '[ty] s a) + , r ~ Code a + ) + => Gettable (RTOptic_ :: Optic ix (Code s) r) + where +instance ( Integral ty, IntegralTy ty + , ix ~ '[Code ty] + , Gettable (RTOptic_ :: Optic '[ty] s a) + , ReifiedGetter (RTOptic_ :: Optic '[ty] s a) + , PrimTy a, PrimTy s + , KnownOptic (RTOptic_ :: Optic '[ty] s a) + , r ~ Code a + ) + => ReifiedGetter (RTOptic_ :: Optic ix (Code s) r) + where + view = fromAST + $ View + sLength + ( opticSing @(RTOptic_ :: Optic '[ty] s a) ) +instance ( Integral ty + , ix ~ '[Code ty] + , Settable (RTOptic_ :: Optic '[ty] s a) + , r ~ Code a + ) + => Settable (RTOptic_ :: Optic ix (Code s) r) + where +instance ( Integral ty, IntegralTy ty + , ix ~ '[Code ty] + , Settable (RTOptic_ :: Optic '[ty] s a) + , ReifiedSetter (RTOptic_ :: Optic '[ty] s a) + , PrimTy s, PrimTy a + , KnownOptic (RTOptic_ :: Optic '[ty] s a) + , r ~ Code a + ) + => ReifiedSetter (RTOptic_ :: Optic ix (Code s) r) + where + set = fromAST + $ Set + sLength + ( opticSing @(RTOptic_ :: Optic '[ty] s a) ) + +-- *** Compile-time index + +instance ( empty ~ '[] + , KnownNat i + , r ~ Code a + , KnownOptic (Field_ i :: Optic empty s a) + ) + => KnownASTOptic (Field_ i :: Optic empty (Code s) r) (Field_ i :: Optic '[] s a) + where +instance ( KnownNat i + , empty ~ '[] + , Gettable (Field_ i :: Optic '[] s a) + , r ~ Code a + ) + => Gettable (Field_ i :: Optic empty (Code s) r) + where +instance ( KnownNat i + , empty ~ '[] + , Gettable (Field_ i :: Optic '[] s a) + , ReifiedGetter (Field_ i :: Optic '[] s a) + , PrimTy a, PrimTy s + , KnownOptic (Field_ i :: Optic '[] s a) + , r ~ Code a + ) + => ReifiedGetter (Field_ i :: Optic empty (Code s) r) + where + view = fromAST + $ View + sLength + ( opticSing @(Field_ i :: Optic '[] s a) ) +instance ( KnownNat i + , empty ~ '[] + , Settable (Field_ i :: Optic '[] s a) + , r ~ Code a + ) + => Settable (Field_ i :: Optic empty (Code s) r) + where +instance ( KnownNat i + , empty ~ '[] + , Settable (Field_ i :: Optic '[] s a) + , ReifiedSetter (Field_ i :: Optic '[] s a) + , PrimTy s, PrimTy a + , KnownOptic (Field_ i :: Optic '[] s a) + , r ~ Code a + ) + => ReifiedSetter (Field_ i :: Optic empty (Code s) r) + where + set = fromAST + $ Set + sLength + ( opticSing @(Field_ i :: Optic '[] s a) ) + + +-- ** Composite instances + +-- *** Containers +-- +-- $containers +-- Container instances, for product optics. + +instance Container (Code (V n a)) where + type FieldIndexFromName (Code (V n a)) k + = TypeError ( Text "optic: attempt to index a vector component with name " :<>: ShowType k + :$$: Text "Maybe you intended to use a swizzle?" + ) +instance KnownNat m => Container (Code (M m n a)) where +instance Container (Code (Struct (as :: [Symbol :-> Type]))) where + type FieldIndexFromName (Code (Struct (as :: [Symbol :-> Type]))) k + = Key (StructIndexFromName k as) +instance Container (Code (Array n a)) where +instance Container (Code (RuntimeArray a)) where + +-- *** Optic focusing on parts with a given type +-- +-- $oftype +-- Setter instances for 'OfType' optic. + +instance ( empty ~ '[] + , r ~ Code ty + , KnownOptic (OfType_ ty :: Optic '[] s ty) + ) + => KnownASTOptic + (OfType_ (Code ty) :: Optic empty (Code s) r ) + (OfType_ ty :: Optic '[] s ty) + where +instance {-# OVERLAPPING #-} + ( empty ~ '[] + , r ~ Code ty + , Settable (OfType_ ty :: Optic '[] s ty) + ) + => Settable (OfType_ (Code ty) :: Optic empty (Code s) r) + where +instance {-# OVERLAPPING #-} + ( empty ~ '[] + , r ~ Code ty + , Settable (OfType_ ty :: Optic '[] s ty) + , KnownOptic (OfType_ ty :: Optic '[] s ty) + , PrimTy s + , PrimTy ty + ) + => ReifiedSetter (OfType_ (Code ty) :: Optic empty (Code s) r) + where + set = fromAST + $ Set + sLength + ( opticSing @(OfType_ ty :: Optic '[] s ty) ) + +-- *** Compound instance resolution + +-- **** Composites + +instance {-# OVERLAPPING #-} + forall is js ks s x y + (o1 :: Optic is (Code s) x) (o2 :: Optic js x y) + is' js' ks' a b + (o1' :: Optic is' s a) (o2' :: Optic js' a b) + . + ( KnownASTOptic o1 o1' + , KnownASTOptic o2 o2' + , ks ~ ( is :++: js ) + , ks' ~ ( is' :++: js' ) + , KnownLength ks' + , x ~ Code a + , y ~ Code b + ) + => KnownASTOptic + ( (o1 `ComposeO` o2 ) :: Optic ks (Code s) y ) + ( (o1' `ComposeO` o2') :: Optic ks' s b ) + where +instance {-# OVERLAPPING #-} + forall is js ks s x y + (o1 :: Optic is (Code s) x) (o2 :: Optic js x y) + is' js' ks' a b + (o1' :: Optic is' s a) (o2' :: Optic js' a b) + . + ( Gettable o1 + , Gettable o2 + , ReifiedGetter ( ( o1' `ComposeO` o2' ) :: Optic ks' s b ) + , KnownASTOptic o1 o1' + , KnownASTOptic o2 o2' + , ks ~ ( is :++: js ) + , ks' ~ ( is' :++: js' ) + , KnownLength ks' + , x ~ Code a + , y ~ Code b + , Syntactic (ListVariadic (ks `Postpend` Code s) y) + , Internal (ListVariadic (ks `Postpend` Code s) y) + ~ AugListVariadic (ks' `Snoc` s) b + ) + => ReifiedGetter ( (o1 `ComposeO` o2) :: Optic ks (Code s) y ) + where + view = fromAST + $ View sLength ( opticSing @o1' %:.: opticSing @o2' ) +instance {-# OVERLAPPING #-} + forall is js ks s x y + (o1 :: Optic is (Code s) x) (o2 :: Optic js x y) + is' js' ks' a b + (o1' :: Optic is' s a) (o2' :: Optic js' a b) + . + ( Settable o1 + , Settable o2 + , ReifiedSetter ( ( o1' `ComposeO` o2' ) :: Optic ks' s b ) + , KnownASTOptic o1 o1' + , KnownASTOptic o2 o2' + , ks ~ ( is :++: js ) + , ks' ~ ( is' :++: js' ) + , KnownLength ks' + , x ~ Code a + , y ~ Code b + , Syntactic (ListVariadic (ks `Postpend` y `Postpend` Code s) (Code s)) + , Internal (ListVariadic (ks `Postpend` y `Postpend` Code s) (Code s)) + ~ AugListVariadic (ks' `Snoc` b `Snoc` s) s + ) + => ReifiedSetter ( (o1 `ComposeO` o2) :: Optic ks (Code s) y ) + where + set = fromAST + $ Set sLength ( opticSing @o1' %:.: opticSing @o2' ) + +-- **** Products +type family MapAST (as :: [Type]) = (r :: [Type]) | r -> as where + MapAST '[] = '[] + MapAST (a ': as) = Code a ': MapAST as + +type family MapMapAST (iss :: [[Type]]) = (r :: [[Type]]) | r -> iss where + MapMapAST '[] = '[] + MapMapAST (is ': iss) = MapAST is ': MapMapAST iss + +instance forall + ( s :: Type ) + ( p :: Type ) + ( p' :: Type ) + ( iss :: [[Type]] ) + ( iss' :: [[Type]] ) + ( js :: [Type] ) + ( js' :: [Type] ) + ( as :: [Type] ) + ( as' :: [Type] ) + ( os :: ProductComponents iss s as ) + ( os' :: ProductComponents iss' (Code s) as' ) + . ( KnownASTOpticComponents os' os + , KnownComponents os + , KnownLength js + , KnownOptic (Prod_ os :: Optic js s p) + , SameLength (Distribute iss as ) as + , SameLength (Distribute iss' as') as' + , IsProduct p as + , p' ~ Code p + , as' ~ MapAST as + , AreProducts js iss as + , js ~ MapHList iss + , js' ~ MapAST js + , PrimTy p + ) + => KnownASTOptic + ( Prod_ os' :: Optic js' (Code s) p' ) + ( Prod_ os :: Optic js s p ) + where +instance {-# OVERLAPPING #-} + forall + ( s :: Type ) + ( p :: Type ) + ( p' :: Type ) + ( iss :: [[Type]] ) + ( iss' :: [[Type]] ) + ( js :: [Type] ) + ( js' :: [Type] ) + ( as :: [Type] ) + ( as' :: [Type] ) + ( os :: ProductComponents iss s as ) + ( os' :: ProductComponents iss' (Code s) as' ) + . ( ComponentsGettable os + , KnownASTOpticComponents os' os + , KnownComponents os + , KnownOptic (Prod_ os :: Optic js s p) + , SameLength (Distribute iss as ) as + , SameLength (Distribute iss' as') as' + , IsProduct p as + , p' ~ Code p + , as' ~ MapAST as + , js' ~ MapAST js + , AreProducts js iss as + , js ~ MapHList iss + , KnownLength js + , PrimTy p + , Syntactic (ListVariadic (js' `Postpend` Code s) p') + , Internal (ListVariadic (js' `Postpend` Code s) p') + ~ AugListVariadic (js `Snoc` s) p + ) + => Gettable (Prod_ os' :: Optic js' (Code s) p') where +instance {-# OVERLAPPING #-} + forall + ( s :: Type ) + ( p :: Type ) + ( p' :: Type ) + ( iss :: [[Type]] ) + ( iss' :: [[Type]] ) + ( js :: [Type] ) + ( js' :: [Type] ) + ( as :: [Type] ) + ( as' :: [Type] ) + ( os :: ProductComponents iss s as ) + ( os' :: ProductComponents iss' (Code s) as' ) + . ( ComponentsGettable os + , KnownASTOpticComponents os' os + , KnownComponents os + , KnownOptic (Prod_ os :: Optic js s p) + , ReifiedGetter (Prod_ os :: Optic js s p) + , SameLength (Distribute iss as ) as + , SameLength (Distribute iss' as') as' + , IsProduct p as + , p' ~ Code p + , as' ~ MapAST as + , js' ~ MapAST js + , AreProducts js iss as + , js ~ MapHList iss + , KnownLength js + , PrimTy p + , Syntactic (ListVariadic (js' `Postpend` Code s) p') + , Internal (ListVariadic (js' `Postpend` Code s) p') + ~ AugListVariadic (js `Snoc` s) p + ) + => ReifiedGetter (Prod_ os' :: Optic js' (Code s) p') where + view = fromAST + $ View sLength ( opticSing @(Prod_ os :: Optic js s p) ) + +instance {-# OVERLAPPING #-} + forall + ( s :: Type ) + ( p :: Type ) + ( p' :: Type ) + ( iss :: [[Type]] ) + ( iss' :: [[Type]] ) + ( js :: [Type] ) + ( js' :: [Type] ) + ( as :: [Type] ) + ( as' :: [Type] ) + ( os :: ProductComponents iss s as ) + ( os' :: ProductComponents iss' (Code s) as' ) + . ( ComponentsSettable os + , ArePairwiseDisjoint os + , KnownASTOpticComponents os' os + , KnownComponents os + , KnownOptic (Prod_ os :: Optic js s p) + , SameLength (Distribute iss as ) as + , SameLength (Distribute iss' as') as' + , IsProduct p as + , p' ~ Code p + , as' ~ MapAST as + , js' ~ MapAST js + , AreProducts js iss as + , js ~ MapHList iss + , KnownLength js + , PrimTy p + , Syntactic (ListVariadic (js' `Postpend` p' `Postpend` Code s) (Code s)) + , Internal (ListVariadic (js' `Postpend` p' `Postpend` Code s) (Code s)) + ~ AugListVariadic (js `Snoc` p `Snoc` s) s + ) + => Settable (Prod_ os' :: Optic js' (Code s) p') where +instance {-# OVERLAPPING #-} + forall + ( s :: Type ) + ( p :: Type ) + ( p' :: Type ) + ( iss :: [[Type]] ) + ( iss' :: [[Type]] ) + ( js :: [Type] ) + ( js' :: [Type] ) + ( as :: [Type] ) + ( as' :: [Type] ) + ( os :: ProductComponents iss s as ) + ( os' :: ProductComponents iss' (Code s) as' ) + . ( ComponentsSettable os + , ArePairwiseDisjoint os + , KnownASTOpticComponents os' os + , KnownComponents os + , KnownOptic (Prod_ os :: Optic js s p) + , ReifiedSetter (Prod_ os :: Optic js s p) + , SameLength (Distribute iss as ) as + , SameLength (Distribute iss' as') as' + , IsProduct p as + , p' ~ Code p + , as' ~ MapAST as + , js' ~ MapAST js + , AreProducts js iss as + , js ~ MapHList iss + , KnownLength js + , PrimTy p + , Syntactic (ListVariadic (js' `Postpend` p' `Postpend` Code s) (Code s)) + , Internal (ListVariadic (js' `Postpend` p' `Postpend` Code s) (Code s)) + ~ AugListVariadic (js `Snoc` p `Snoc` s) s + ) + => ReifiedSetter (Prod_ os' :: Optic js' (Code s) p') where + set = fromAST + $ Set (sLength @_ @js) ( opticSing @(Prod_ os :: Optic js s p) ) + +class KnownASTOpticComponents ast_os os | ast_os -> os where +instance ( iss ~ jss, as ~ '[], bs ~ '[] ) + => KnownASTOpticComponents + ( EndProd_ :: ProductComponents iss (Code s) as ) + ( EndProd_ :: ProductComponents jss s bs ) + where +instance ( KnownASTOptic o' o + , KnownASTOpticComponents os' os + , as' ~ MapAST as + , iss' ~ MapMapAST iss + ) + => KnownASTOpticComponents + ( (o' `ProductO` os') :: ProductComponents iss' (Code s) ( a' ': as' ) ) + ( (o `ProductO` os ) :: ProductComponents iss s ( a ': as ) ) + where + +----------------------------------------------- +-- * Functor functionality + +infixl 4 <$$> +infixl 4 <**> + +class ( Typeable f, forall x. ASTApplicativeElt f x => PrimTy (f x) ) => ASTApplicative f where + type ASTApplicativeElt f (x :: Type) :: Constraint + pureAST + :: ( FunRes a ~ Val va, PrimTy va + , All PrimTyVal (FunArgs a) + ) + => AST a -> AST (ApplyFAug f a) + (<**>) :: ( Syntactic fb, Internal fb ~ ApplyFAug f b, PrimTy a ) + => ( AST ( Val (f a) :--> ApplyFAug f b ) ) -> Code (f a) -> fb + +(<$$>), fmapAST + :: forall f a b fb vb + . ( ASTApplicative f + , PrimTy a + , FunRes (Internal b) ~ Val vb + , PrimTy vb + , Syntactic b + , Syntactic fb + , Internal fb ~ ApplyFAug f (Internal b) + , All PrimTyVal (FunArgs (Internal b)) + ) + => ( Code a -> b ) -> ( Code (f a) -> fb ) +(<$$>) = fmapAST +fmapAST f fa = fromAST ( pureAST (toAST f) <**> fa ) + + +instance KnownNat n => ASTApplicative (V n) where + type ASTApplicativeElt (V n) x = PrimTy x + pureAST = Pure ( Proxy @(V n) ) + fab <**> fa = fromAST $ Ap ( Proxy @(V n) ) fab fa + +instance (KnownNat m, KnownNat n) => ASTApplicative (M m n) where + type ASTApplicativeElt (M m n) x = ( ScalarTy x, Ring x ) + pureAST = Pure ( Proxy @(M m n) ) + fab <**> fa = fromAST $ Ap ( Proxy @(M m n) ) fab fa + +instance KnownNat n => ASTApplicative (Array n) where + type ASTApplicativeElt (Array n) x = PrimTy x + pureAST = Pure ( Proxy @(Array n) ) + fab <**> fa = fromAST $ Ap ( Proxy @(Array n) ) fab fa + +{- +instance + TypeError ( Text "The Code datatype does not have a Functor instance:" + :$$: Text " cannot map Haskell functions over internal types." + :$$: Text "To map an internal function over an internal type, use 'fmapAST'/'<$$>'." + ) => Prelude.Functor AST where + fmap = error "unreachable" +-} + +----------------------------------------------- +-- * Internal functors +-- +-- $internalfunctors +-- Instances for vectors, matrices and arrays. + +instance KnownNat n => PrimFunc (V n) where + primFuncSing = SFuncVector @n + distDict = DistDict +instance ( KnownNat m, KnownNat n ) => PrimFunc (M m n) where + primFuncSing = SFuncMatrix @m @n + distDict = DistDict +instance KnownNat n => PrimFunc (Array n) where + primFuncSing = SFuncArray @n + distDict = DistDict + +----------------------------------------------- +-- * Syntactic instances +-- +-- $syntactic +-- Instances for 'Syntactic'. + +instance Syntactic () where + type Internal () = Val () + toAST = const ( Lit () ) + fromAST = const () + +instance ( Syntactic a, Syntactic b + , Internal a ~ Val va, PrimTy va + , Internal b ~ Val vb, PrimTy vb + ) => Syntactic (a,b) where + type Internal (a,b) = + Val (Struct + '[ "_0" ':-> InternalType a + , "_1" ':-> InternalType b + ] ) + toAST (a,b) = Struct ( toAST a :& toAST b :& End ) + fromAST struct = + ( fromAST (view @(Index 0) struct) + , fromAST (view @(Index 1) struct) + ) + +instance ( Syntactic a, Syntactic b, Syntactic c + , Internal a ~ Val va, PrimTy va + , Internal b ~ Val vb, PrimTy vb + , Internal c ~ Val vc, PrimTy vc + ) => Syntactic (a,b,c) where + type Internal (a,b,c) = + Val ( Struct + '[ "_0" ':-> InternalType a + , "_1" ':-> InternalType b + , "_2" ':-> InternalType c + ] ) + toAST (a,b,c) = Struct ( toAST a :& toAST b :& toAST c :& End ) + fromAST struct = + ( fromAST (view @(Index 0) struct) + , fromAST (view @(Index 1) struct) + , fromAST (view @(Index 2) struct) + ) + +instance ( KnownNat n + , Syntactic a + , Internal a ~ Val v + , PrimTy v + ) + => Syntactic (V n a) + where + type Internal (V n a) = Val (V n (InternalType a)) + + toAST :: V n a -> Code (V n (InternalType a)) + toAST = MkVector . Prelude.fmap toAST + + fromAST :: Code (V n (InternalType a)) -> V n a + fromAST v = buildV @n builder + where builder :: forall i. (KnownNat i, CmpNat i n ~ Prelude.LT) + => Proxy i -> a + builder _ = fromAST ( View sLength (opticSing @(Index i)) :$ v ) + +instance ( KnownNat m, KnownNat n + , Syntactic a, Internal a ~ Val v, PrimTy v + ) + => Syntactic (M m n a) where + type Internal (M m n a) = Val (M m n (InternalType a)) + toAST (M m) = Mat :$ toAST m + fromAST = M . fromAST . ( UnMat :$ ) + +instance ( KnownNat n + , Syntactic a, Internal a ~ Val v, PrimTy v + ) + => Syntactic (Array n a) where + type Internal (Array n a) = Val (Array n (InternalType a)) + toAST arr = Array $ Prelude.fmap toAST arr + fromAST arr = MkArray vec + where + vec :: Vector.Vector n a + vec = Vector.generate ( withFinite ( \ ( _ :: Proxy i ) -> fromAST $ view @(Index i) arr ) ) + +----------------------------------------------- +-- * Vectors and matrices + +-- ** Vectors +-- +-- $vectors +-- Instances for: +-- +-- 'Semimodule', 'LinearModule', 'Inner', 'Cross'. +instance (ScalarTy a, Semiring a) => Semimodule Nat (Code (V 0 a)) where + type Scalar (Code (V 0 a)) = Code a + type OfDim (Code (V 0 a)) Nat n = Code (V n a) + type ValidDim (Code (V 0 a)) Nat n = KnownNat n + + (^+^) :: forall n. KnownNat n + => Code (V n a) -> Code (V n a) -> Code (V n a) + (^+^) = primOp @(V n a) @('Vectorise SPIRV.Add) + + (^*) :: forall n. KnownNat n + => Code (V n a) -> Code a -> Code (V n a) + (^*) = case scalarTySing @a of + SHalf -> primOp @(V n a) @SPIRV.VMulK + SFloat -> primOp @(V n a) @SPIRV.VMulK + SDouble -> primOp @(V n a) @SPIRV.VMulK + -- No "vector times scalar" operation in SPIR-V + -- for integral scalar types. + _ -> ( \ vec a -> toAST $ Prelude.fmap ( * a ) ( fromAST vec :: V n ( Code a ) ) ) + +instance (ScalarTy a, Ring a) => LinearModule Nat (Code (V 0 a)) where + (^-^) :: forall n. KnownNat n + => Code (V n a) -> Code (V n a) -> Code (V n a) + (^-^) = primOp @(V n a) @('Vectorise SPIRV.Sub) + + (-^) :: forall n. KnownNat n => Code (V n a) -> Code (V n a) + (-^) = primOp @(V n a) @('Vectorise SPIRV.Neg) + +instance (ScalarTy a, Floating a) => Inner Nat (Code (V 0 a)) where + (^.^) :: forall n. KnownNat n + => Code (V n a) -> Code (V n a) -> Code a + (^.^) = primOp @(V n a) @SPIRV.DotV + + normalise :: forall n. KnownNat n => Code (V n a) -> Code (V n a) + normalise = primOp @(V n a) @SPIRV.NormaliseV + +instance (ScalarTy a, Floating a) => Cross Nat (Code (V 0 a)) where + type CrossDim (Code (V 0 a)) Nat n = ( n ~ 3 ) + + cross :: Code (V 3 a) -> Code (V 3 a) -> Code (V 3 a) + cross = primOp @(V 3 a) @SPIRV.CrossV + + +-- ** Matrices +-- +-- $matrices +-- Instance for 'Matrix'. + +type instance VectorOf (Code (M 0 0 a)) = Code (V 0 a) + +instance (ScalarTy a, Floating a) => Matrix Nat (Code (M 0 0 a)) where + type OfDims (Code (M 0 0 a)) Nat '(m,n) = Code (M m n a) + + diag :: forall (n :: Nat). KnownNat n => Code a -> Code (M n n a) + diag a = toAST (M mat) + where + indicator :: (KnownNat i, KnownNat j) => Proxy i -> Proxy j -> Code a + indicator px1 px2 = case sameNat px1 px2 of + Just _ -> a + _ -> zero + mat :: V n (V n (Code a)) + mat = buildV @n ( \ px1 -> buildV @n ( \ px2 -> indicator px1 px2 ) ) + + konst a = Mat :$ pureAST (pureAST a) + + transpose :: forall n m. (KnownNat n, KnownNat m) + => Code (M n m a) -> Code (M m n a) + transpose = primOp @'(a,n,m) @SPIRV.Transp + + inverse :: forall n. KnownNat n + => Code (M n n a) -> Code (M n n a) + inverse = primOp @'(a,n) @SPIRV.Inv + + determinant :: forall n. KnownNat n + => Code (M n n a) -> Code a + determinant = primOp @'(a,n) @SPIRV.Det + + -- no built-in matrix addition and subtraction, so we use the vector operations + (!+!) :: forall i j. (KnownNat i, KnownNat j) + => Code (M i j a) -> Code (M i j a) -> Code (M i j a) + x !+! y = Mat :$ ( vecAdd <$$> (UnMat :$ x) <**> (UnMat :$ y) ) + where vecAdd :: Code (V i a) -> Code (V i a) -> Code (V i a) + vecAdd = primOp @(V i a) @('Vectorise SPIRV.Add) + (!-!) :: forall i j. (KnownNat i, KnownNat j) + => Code (M i j a) -> Code (M i j a) -> Code (M i j a) + x !-! y = Mat :$ ( vecSub <$$> (UnMat :$ x) <**> (UnMat :$ y) ) + where vecSub :: Code (V i a) -> Code (V i a) -> Code (V i a) + vecSub = primOp @(V i a) @('Vectorise SPIRV.Sub) + + (!*!) :: forall i j k. (KnownNat i, KnownNat j, KnownNat k) + => Code (M i j a) -> Code (M j k a) -> Code (M i k a) + (!*!) = primOp @'(a,i,j,k) @SPIRV.MMulM + + (^*!) :: forall i j. (KnownNat i, KnownNat j) + => Code (V i a) -> Code (M i j a) -> Code (V j a) + (^*!) = primOp @'(a,i,j) @SPIRV.VMulM + + (!*^) :: forall i j. (KnownNat i, KnownNat j) + => Code (M i j a) -> Code (V j a) -> Code (V i a) + (!*^) = primOp @'(a,i,j) @SPIRV.MMulV + + (!*) :: forall i j. (KnownNat i, KnownNat j) + => Code (M i j a) -> Code a -> Code (M i j a) + (!*) = primOp @'(a,i,j) @SPIRV.MMulK + +instance GradedSemigroup (Code (V 0 a)) Nat where + type Grade Nat (Code (V 0 a)) n = Code (V n a) + type n1 :: n2 = n1 + n2 + () = fromAST GradedMappend diff --git a/src/FIR/Syntax/Complex.hs b/src/FIR/Syntax/Complex.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/Complex.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Syntax.Complex + +Syntax for manipulating complex numbers. + +@CodeComplex a@ is a newtype around @Code (V 2 a)@, but with a @ComplexFloat@ instance allowing for complex arithmetic. + +Complex numbers can be constructed using using @:+:@, e.g. @0 :+: 1@ represents the imaginary unit @i@. + +Note that @Floating@ operations such as trigonometric functions are not provided, as these are not supported by @SPIR-V@. +-} + + +module FIR.Syntax.Complex + ( CodeComplex(..), pattern (:+:), complexLog ) + where + +-- fir +import Math.Algebra.Class + ( AdditiveMonoid(..), CancellativeAdditiveMonoid(..), AdditiveGroup(..) + , Semiring(..), DivisionRing(..) + , Floating(..), RealFloat(..), ComplexFloat(..) + ) +import Math.Logic.Class + ( Eq(Logic) ) +import Math.Linear + ( V, (^+^), (^-^), (-^), (*^) ) +import FIR.AST + ( Code, Syntactic(..), SyntacticVal, InternalType ) +import FIR.AST.Type + ( AugType(Val) ) +import FIR.Prelude +import FIR.Prim.Types + ( PrimTy, ScalarTy ) +import FIR.Syntax.AST + ( ) +import FIR.Syntax.Synonyms + ( pattern Vec2 ) + +---------------------------------------------------------------------------- + +-- | Newtype around @Code (V 2 a)@, but with typeclass instances +-- for complex arithmetic. +newtype CodeComplex a = CodeComplex { codeComplex :: Code ( V 2 a ) } + +instance (ScalarTy a) => Syntactic (CodeComplex a) where + type Internal (CodeComplex a) = Val ( V 2 a ) + toAST ( CodeComplex vec ) = vec + fromAST vec = CodeComplex vec + +instance (SyntacticVal a, ScalarTy (InternalType a)) => Syntactic (Complex a) where + type Internal (Complex a) = Val ( V 2 (InternalType a) ) + toAST (x :+ y) = Vec2 ( toAST x ) ( toAST y ) + fromAST (Vec2 x y) = fromAST x :+ fromAST y + +{-# COMPLETE (:+:) #-} +pattern (:+:) :: PrimTy a => Code a -> Code a -> CodeComplex a +pattern a :+: b = CodeComplex ( Vec2 a b ) + +instance ( Semiring a, ScalarTy a ) => AdditiveMonoid (CodeComplex a) where + (+) = coerce ( (^+^) :: Code ( V 2 a ) -> Code ( V 2 a ) -> Code ( V 2 a ) ) + zero = zero :+: zero + fromInteger a = fromInteger a :+: zero + +instance ( Semiring a, CancellativeAdditiveMonoid a, ScalarTy a ) => Semiring (CodeComplex a) where + ( a1 :+: b1 ) * ( a2 :+: b2 ) = ( a1 * a2 - b1 * b2 ) :+: ( a1 * b2 + b1 * a2 ) + +instance ( Semiring a, AdditiveGroup a, ScalarTy a ) => CancellativeAdditiveMonoid (CodeComplex a) where + (-) = coerce ( (^-^) :: Code ( V 2 a ) -> Code ( V 2 a ) -> Code ( V 2 a ) ) + +instance ( Semiring a, AdditiveGroup a, ScalarTy a ) => AdditiveGroup (CodeComplex a) where + negate = coerce ( (-^) :: Code ( V 2 a ) -> Code ( V 2 a ) ) + +instance ( RealFloat a, ScalarTy a, Logic a ~ Bool ) => DivisionRing (CodeComplex a) where + z1 / ( z2@( a2 :+: b2 ) ) = scale ( recip $ sqMag_z2 ) ( z1 * conjugate z2 ) + where + sqMag_z2 :: Code a + sqMag_z2 = a2 * a2 + b2 * b2 + fromRational r = fromRational r :+: zero + +instance ( b ~ Code a, ScalarTy a, RealFloat a, Logic a ~ Bool ) => ComplexFloat (CodeComplex a) b where + conjugate ( a :+: b ) = a :+: negate b + magnitude ( a :+: b ) = sqrt ( a * a + b * b ) + squaredMagnitude ( a :+: b ) = a * a + b * b + phase ( a :+: b ) = atan2 b a + mkCartesian a b = a :+: b + mkPolar r theta = scale r $ cis theta + cis theta = cos theta :+: sin theta + scale r = coerce ( ( r *^ ) :: Code ( V 2 a ) -> Code ( V 2 a ) ) + realPart ( a :+: _ ) = a + imagPart ( _ :+: b ) = b + +complexLog :: ( ScalarTy a, RealFloat a, Logic a ~ Bool ) => CodeComplex a -> CodeComplex a +complexLog z = log ( magnitude z ) :+: phase z diff --git a/src/FIR/Syntax/DebugPrintf.hs b/src/FIR/Syntax/DebugPrintf.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/DebugPrintf.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +{-| +Module: FIR.Syntax.DebugPrintf +Description: @---@ Printf-like formatting functionality (for shader debugging). +-} + +module FIR.Syntax.DebugPrintf + ( Format, Formatter + , debugPrintf + , (%) + , int32, word32, word32Hex + , float, scientific + , vec + ) + where + +-- base +import Data.Int + ( Int32 ) +import Data.Kind + ( Type ) +import Data.Word + ( Word32 ) +import Data.String + ( IsString(..) ) +import GHC.Exts + ( proxy#, Proxy# ) +import GHC.TypeNats + ( Nat, KnownNat + , type (<=) + , natVal' + ) + +-- text-short +import Data.Text.Short + ( ShortText ) +import qualified Data.Text.Short as ShortText + ( pack ) + +-- fir +import Data.Constraint.All + ( All ) +import Data.Type.List + ( type (:++:) ) +import FIR.AST + ( Code, Syntactic(..) + , PrintfAugType, pattern DebugPrintf + ) +import FIR.AST.Type + ( FunArgs, Nullary ) +import FIR.Module + ( Program ) +import FIR.ProgramState + ( ProgramState ) +import Math.Linear + ( V ) + +---------------------------------------------------------------------------- + +-- | A printf format, taking parameters of the given types. +data Format ( as :: [ Type ] ) = + UnsafeFormatFromFormatString { formatString :: !ShortText } + deriving stock ( Eq, Show ) + +-- | Print to debug output using a printf-style formatter. +-- +-- Need to pass the 'Debug' compiler flag (otherwise this instruction will be ignored). +-- +-- /Usage/: say we want to print the following values: +-- +-- > x :: Code Float +-- > y :: Code Int32 +-- > z :: Code (V 2 Float) +-- +-- We can do this using the command: +-- > debugPrintf ( "x = " % float % " y = " % int32 % " z = " % vec @2 float ) x y z +-- +-- '(%)' denotes composition of formatters. +-- +-- /Note/: Enabling the OverloadedStrings extension is necessary. +-- +-- To see this output, enable the following layers (off by default): +-- +-- > VK_LAYER_PRINTF_ENABLE=1 VK_LAYER_PRINTF_TO_STDOUT=1 \ +-- > VK_LAYER_PRINTF_ONLY_PRESET=1 VK_LAYER_PRINTF_BUFFER_SIZE=1048576 +debugPrintf + :: forall + ( as :: [Type ] ) + ( i :: ProgramState ) + . ( Syntactic ( ProgPrintf i as ) + , Internal ( ProgPrintf i as ) ~ PrintfAugType i as + , All Nullary ( FunArgs ( PrintfAugType i as ) ) + ) + => Format as -> ProgPrintf i as +debugPrintf fmt = fromAST ( DebugPrintf ( formatString fmt ) ) + +type family ProgPrintf ( i :: ProgramState ) ( as :: [ Type ] ) = ( r :: Type ) | r -> i as where + ProgPrintf i '[] = Program i i ( Code () ) + ProgPrintf i ( a ': as ) = Code a -> ProgPrintf i as + + +instance ( as ~ '[] ) => IsString ( Format as ) where + fromString + = UnsafeFormatFromFormatString + . fromString + . escapePercents + +escapePercents :: [Char] -> [Char] +escapePercents [] = [] +escapePercents ( '%' : as ) = '%' : '%' : escapePercents as +escapePercents ( c : as ) = c : escapePercents as + +infixr 9 % +-- | Concatenate two formatters. +-- +-- See 'debugPrintf' for example usage. +(%) :: Format as -> Format bs -> Format ( as :++: bs ) +( UnsafeFormatFromFormatString a ) % ( UnsafeFormatFromFormatString b ) = + UnsafeFormatFromFormatString ( a <> b ) + +-- | A class for types which can be formatted. +class Formattable ( a :: Type ) where + data Formatter a :: Type + formatterString :: Formatter a -> ShortText + +instance Formattable Int32 where + data Formatter Int32 + = FormatInt32 + formatterString _ = "i" + +instance Formattable Word32 where + data Formatter Word32 + = FormatWord32 + | FormatWord32Hex + formatterString FormatWord32 = "u" + formatterString FormatWord32Hex = "X" + +instance Formattable Float where + data Formatter Float + = FormatFloatDigits + | FormatFloatScientific + | FormatFloatGeneric + formatterString FormatFloatDigits = "f" + formatterString FormatFloatScientific = "e" + formatterString FormatFloatGeneric = "g" + +instance ( KnownNat n, 2 <= n, n <= 4, Formattable a ) => Formattable ( V n a ) where + data Formatter ( V n a ) + = FormatVec ( Formatter a ) + formatterString ( FormatVec fmt ) = "v" <> n <> formatterString fmt + where + n :: ShortText + n = ShortText.pack . show $ natVal' ( proxy# :: Proxy# n ) + +mkFormatter :: Formattable a => Formatter a -> Format '[ a ] +mkFormatter fmt = UnsafeFormatFromFormatString ( "%" <> formatterString fmt ) + +class Int32Formatter r where + int32 :: r +instance ( as ~ '[ Int32 ] ) => Int32Formatter ( Format as ) where + int32 = mkFormatter FormatInt32 +instance ( a ~ Int32 ) => Int32Formatter ( Formatter a ) where + int32 = FormatInt32 + +class Word32Formatter r where + word32 :: r + word32Hex :: r +instance ( as ~ '[ Word32 ] ) => Word32Formatter ( Format as ) where + word32 = mkFormatter FormatWord32 + word32Hex = mkFormatter FormatWord32Hex +instance ( a ~ Word32 ) => Word32Formatter ( Formatter a ) where + word32 = FormatWord32 + word32Hex = FormatWord32Hex + +class FloatFormatter r where + float :: r + scientific :: r +instance ( as ~ '[ Float ] ) => FloatFormatter ( Format as ) where + float = mkFormatter FormatFloatDigits + scientific = mkFormatter FormatFloatScientific +instance ( a ~ Float ) => FloatFormatter ( Formatter a ) where + float = FormatFloatDigits + scientific = FormatFloatScientific + +class ( KnownNat n, 2 <= n, n <= 4, Formattable a ) => VecFormatter (n :: Nat) a r | r -> n a where + vec :: Formatter a -> r +instance ( KnownNat n, 2 <= n, n <= 4, Formattable a, as ~ '[ V n a ] ) + => VecFormatter n a ( Format as ) where + vec fmt = mkFormatter ( FormatVec fmt ) +instance ( KnownNat n, 2 <= n, n <= 4, Formattable a, v ~ V n a ) + => VecFormatter n a ( Formatter v ) where + vec fmt = FormatVec fmt diff --git a/src/FIR/Syntax/IfThenElse.hs b/src/FIR/Syntax/IfThenElse.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/IfThenElse.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Syntax.IfThenElse + +This module defines instances used to provide rebindable if-then-else statements. +-} + +module FIR.Syntax.IfThenElse + ( when, unless ) + where + +-- base +import Data.Kind + ( Type ) + +-- fir +import Control.Monad.Indexed + ( (:=), ixPure ) +import FIR.AST + ( Code + , Syntactic(toAST, fromAST) + , SyntacticVal, InternalType + , pattern (:$), pattern Lit + , pattern If, pattern IfM + , pattern Return + ) +import FIR.Module + ( Program ) +import FIR.Prim.Types + ( PrimTy ) +import FIR.Syntax.AST + ( ) +import FIR.Syntax.Program + ( ) +import Math.Logic.Class + ( Choose(choose), Choosing ) + +-------------------------------------------------------------------------------------- + +when :: forall i. Code Bool -> Program i i (Code ()) -> Program i i (Code ()) +when b action + = choose b + ( action ) + ( ixPure (Lit ()) :: Program i i (Code ()) ) + +unless :: forall i. Code Bool -> Program i i (Code ()) -> Program i i (Code ()) +unless b action + = choose b + ( ixPure (Lit ()) :: Program i i (Code ()) ) + ( action ) + +-------------------------------------------------------------------------------------- +-- | The 'Choose' instances provide syntax for rebindable 'ifThenElse'. +-- +-- We uses a helper type class 'Chooser' in an attempt to improve type inference. +instance {-# OVERLAPPABLE #-} + ( b ~ Bool + , Syntactic z + , Chooser x y z (WhichChoice (InternalType z)) + ) + => Choose (Code b) '(x, y, z) where + choose = chosen @x @y @z @(WhichChoice (InternalType z)) +instance ( b ~ Code Bool + , j ~ i, k ~ i, l ~ i + , SyntacticVal z + , x ~ Program i j1 z + , y ~ Program i j2 z + ) + => Choose (Program k l b) '(x, y, Program i j z) where + choose c t f = fromAST ( IfM :$ toAST c :$ toAST t :$ toAST f ) +instance ( b ~ Bool + , j ~ i + , SyntacticVal z + , x ~ Program i j1 z + , y ~ Program i j2 z + ) + => Choose (Code b) '(x, y, Program i j z) where + choose c t f = fromAST ( IfM :$ ( Return :$ c ) :$ toAST t :$ toAST f ) +instance {-# INCOHERENT #-} + ( b ~ Program i i (Code Bool) + , j ~ i + , SyntacticVal z + , x ~ Program i j1 z + , y ~ Program i j2 z + ) + => Choose b '(x, y, Program i j z) where + choose c t f = fromAST ( IfM :$ toAST c :$ toAST t :$ toAST f ) + + +data Choice = PureChoice | ImpureChoice +class Chooser x y z (choice :: Choice) where + chosen :: Choosing (Code Bool) '(x,y,z) +instance ( SyntacticVal z + , PrimTy (InternalType z) + , x ~ z, y ~ z + ) + => Chooser x y z PureChoice where + chosen = fromAST ( If @(InternalType z) ) +instance ( x ~ Program i j1 x' + , y ~ Program i j2 y' + , z ~ Program i i z' + , SyntacticVal z' + , PrimTy (InternalType z') + , x' ~ z' + , y' ~ z' + ) + => Chooser x y z ImpureChoice where + chosen c t f = fromAST ( IfM :$ ( Return :$ c ) :$ toAST t :$ toAST f ) + +type family WhichChoice (z :: Type) :: Choice where + WhichChoice ( (_ := _) _ ) + = ImpureChoice + WhichChoice _ + = PureChoice diff --git a/src/FIR/Syntax/Images.hs b/src/FIR/Syntax/Images.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/Images.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Syntax.Images + +This module allows for the operations 'FIR.Syntax.Program.use' +and 'FIR.Syntax.Program.assign' to work with images, by providing the 'ImageTexel' lens. + +This allows accessing image data in a shader like so: + +@ use \@(ImageTexel "imageName") imageOperands coords @ + +provided that @"imageName"@ binds an image in the monadic context. + +@coords@ are the coordinates at which to access the image. +The specific type of these coordinates depends on: + + * whether we are sampling or reading directly, + * the image dimensionality, + * whether the image is arrayed, + * the type of coordinates being used (affine or projective). + +The return type of this operation depends on: + + * the image format (for instance a normalised integer image format + will return floating-point types), + * whether a depth-comparison is being performed: the return type + will be a scalar in that case, and otherwise a vector with 4 components. + + +These properties are specified either at the type level, +with a top-level type annotation declaring the image properties, +or by the 'FIR.Prim.Image.ImageOperands' @imageOperands@ (optional +unless a depth-comparison value is required, but can be used +e.g. to set an explicit level of detail). + + + +As images in @SPIR-V@ form an opaque type, the corresponding +'FIR.Prim.Image.Image' data type used by this library is +uninhabited, meaning it is impossible to construct or obtain +a value of this type. Instead, 'FIR.Prim.Image.Image' +is used only indirectly. +Attempting to directly obtain an 'FIR.Prim.Image.Image' +results in an error: + +> img <- use @(Name "imgName") +> +> • Variable named "imgName" refers to an image. +> To access image data, use the 'ImageTexel' optic or the 'imageRead' function. + + +-} + +module FIR.Syntax.Images + ( -- * Lens focusing on an image texel + ImageTexel + + -- * Image query operations + , imageSizeLOD, imageSize, imageLOD, imageLevels, imageSamples + + ) +where + +-- base +import Prelude + hiding ( Floating, Integral ) +import Data.Kind + ( Type ) +import Data.Proxy + ( Proxy(..) ) +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( Symbol, KnownSymbol ) + +-- fir +import Control.Type.Optic + ( Optic(Field_, RTOptic_, ComposeO) + , Gettable, Settable + ) +import Data.Type.Known + ( Known ) +import FIR.AST + ( Code, Syntactic(fromAST) + , pattern QuerySize, pattern QuerySizeLOD + , pattern QueryLOD, pattern QueryLevels, pattern QuerySamples + ) +import FIR.Module + ( Program ) +import FIR.Prim.Image + ( ImageProperties + , Image + , OperandName, ImageOperands + ) +import FIR.Prim.Types + ( PrimTy ) +import FIR.ProgramState + ( ProgramState ) +import FIR.Validation.Images + ( LookupImageProperties + , ValidImageRead, ValidImageWrite + , ImageTexelType + , ValidQueryImageSize, ValidQueryImageSizeLOD + , ValidQueryImageLOD, ValidQueryImageLevels, ValidQueryImageSamples + ) + +----------------------------------------------------------------------- + +-- | Lens for focusing on texels of an image. +-- +-- This is a /phantom/ composite @ Name k :.: Texel @, +-- where @Texel@ denotes a (hypothetical) run-time optic +-- which focuses on the texel at a given coordinate (with specified image operands). +-- +-- As it is impossible to obtain actual values of type 'FIR.Prim.Image.Image', +-- it is only the composite optic @ImageTexel k@, understood atomically, +-- which allows focusing on image texels. +type family ImageTexel + ( k :: Symbol ) + = ( optic + :: Optic + '[ ImageOperands props ops, imgCds ] + ( i :: ProgramState ) + ( ImageTexelType props ops ) + ) + | optic -> k + where + forall i props ops imgCds k. + ImageTexel k + = ( ( ( Field_ (k :: Symbol) :: Optic '[] i (Image props) ) + `ComposeO` + ( RTOptic_ + :: Optic + '[ ImageOperands props ops, imgCds ] + ( Image props ) + ( ImageTexelType props ops ) + ) + ) :: Optic + '[ ImageOperands props ops, imgCds ] + i + (ImageTexelType props ops) + ) + +---------------------------------------------------- +-- instances for this particular 'ghost' composite +-- (leverages that normal runtime optics only ever have 1 run-time index, this has 2) + +instance {-# OVERLAPPING #-} + forall + ( k :: Symbol ) + ( i :: ProgramState ) + ( props :: ImageProperties ) + ( ops :: [OperandName] ) + ( empty :: [Type] ) + ( imgOps :: Type ) + ( imgCds :: Type ) + ( imgTexel :: Type ) + . + ( KnownSymbol k + , LookupImageProperties k i ~ props + , Known ImageProperties props + , ValidImageRead props ops imgCds + , empty ~ '[] + , imgOps ~ ImageOperands props ops + , imgTexel ~ ImageTexelType props ops + ) + => Gettable ( ( ( Field_ k :: Optic empty i (Image props)) + `ComposeO` + ( RTOptic_ :: Optic '[imgOps, imgCds] (Image props) imgTexel ) + ) :: Optic '[imgOps, imgCds] i imgTexel + ) + where + +instance {-# OVERLAPPING #-} + forall + ( k :: Symbol ) + ( i :: ProgramState ) + ( props :: ImageProperties ) + ( ops :: [OperandName] ) + ( empty :: [Type] ) + ( imgOps :: Type ) + ( imgCds :: Type ) + ( imgTexel :: Type ) + . + ( KnownSymbol k + , LookupImageProperties k i ~ props + , Known ImageProperties props + , ValidImageWrite props ops imgCds + , empty ~ '[] + , imgOps ~ ImageOperands props ops + , imgTexel ~ ImageTexelType props ops + ) + => Settable ( ( ( Field_ k :: Optic empty i (Image props)) + `ComposeO` + ( RTOptic_ :: Optic '[imgOps, imgCds] (Image props) imgTexel ) + ) :: Optic '[imgOps, imgCds] i imgTexel + ) + where + +----------------------------------------------------------------------- +-- Image query operations. + +-- | Query the size of the named image, at a given level-of-detail. +imageSizeLOD + :: forall + ( imgName :: Symbol ) + ( res :: Type ) + ( i :: ProgramState ) + . ( KnownSymbol imgName + , PrimTy res + , ValidQueryImageSizeLOD imgName i res + ) + => Code Word32 -- ^ Image level-of-detail to use for the query. + -> Program i i ( Code res ) +imageSizeLOD = fromAST ( QuerySizeLOD ( Proxy @imgName ) ( Proxy @res ) ) + +-- | Query the size of the named image. +imageSize + :: forall + ( imgName :: Symbol ) + ( res :: Type ) + ( i :: ProgramState ) + . ( KnownSymbol imgName + , PrimTy res + , ValidQueryImageSize imgName i res + ) + => Program i i ( Code res ) +imageSize = fromAST ( QuerySize ( Proxy @imgName ) ( Proxy @res ) ) + +-- | Query the level of detail of the named image at the given coordinates. +imageLOD + :: forall + ( imgName :: Symbol ) + ( coords :: Type ) + ( res :: Type ) + ( i :: ProgramState ) + . ( KnownSymbol imgName + , PrimTy res + , ValidQueryImageLOD imgName i coords res + ) + => Code coords + -> Program i i ( Code res ) +imageLOD = fromAST ( QueryLOD ( Proxy @imgName ) ( Proxy @res ) ) + +-- | Query how many levels of detail the named image has. +imageLevels + :: forall + ( imgName :: Symbol ) + ( res :: Type ) + ( i :: ProgramState ) + . ( KnownSymbol imgName + , PrimTy res + , ValidQueryImageLevels imgName i res + ) + => Program i i ( Code res ) +imageLevels = fromAST ( QueryLevels ( Proxy @imgName ) ( Proxy @res ) ) + +-- | Query how many samples the named multi-sampling image has. +imageSamples + :: forall + ( imgName :: Symbol ) + ( res :: Type ) + ( i :: ProgramState ) + . ( KnownSymbol imgName + , PrimTy res + , ValidQueryImageSamples imgName i res + ) + => Program i i ( Code res ) +imageSamples = fromAST ( QuerySamples ( Proxy @imgName ) ( Proxy @res ) ) diff --git a/src/FIR/Syntax/Labels.hs b/src/FIR/Syntax/Labels.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/Labels.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Syntax.Labels +Description: @---@ __Optional__ /imperative-style/ syntax using overloaded labels. + +Imperative-like syntax for variable assignment using overloaded labels. /Completely optional./ + +To use this functionality, import this module, activating /OverloadedLabels/ and /RebindableSyntax/. +You'll most likely want to use /TypeApplications/ too. + +Usages of label syntax, such as @#foo@, will be desugared +using the 'fromLabel' method of the 'IsLabel' class in this module. + +This allows for notation such as: + +> do +> #x #= (1 :: Float) -- defines a new variable named 'x', initialised with value (1 :: Float) +> +> #x .= 2 -- sets the value of variable 'x' to 2 +> +> #x %= (*3) -- modifies the value of variable 'x' by multiplying it by 3 +> +> #y @Float #=! 7 -- defines a new constant named 'y', initialised with value (7 :: Float) +> +> z <- #x + #y +> -- 'z' then has value 6+7 = 13 + +In the first four examples, the overloaded labels are desugared into standalone labels, +which are then consumed by the infix operators @#=@, @.=@, @%=@ and @#=!@. + +In the last example, the labels are desugared directly into values, +within the context of the indexed monad of the @do@ block. + +The stateful nature of these labels is worth emphasising. +Consider for instance: + +> do +> #x @Float #= 0 +> x <- #x +> #x .= 1 +> x' <- #x + +When we write @x <- #x@, the /current/ value of @#x@ is obtained from the state. +In this example, this means that @x@ will continue to refer to the value @0@, +even after we set @#x@ to 1. When we retrieve the value of @#x@ after modifying it, +we then give @x'@ the (immutable) value of @1@. + +This subtlety is especially important when working with @while@ loops, +as one wants to avoid having a constant conditional in the header. + +Note that overloaded labels don't support visible type application in GHC 9.0 [due to a bug](https://gitlab.haskell.org/ghc/ghc/-/issues/19154). +For that version of GHC, you will need to write + +> #label #= ( val :: type ) + +instead of + +> #label @type #= val +-} + +module FIR.Syntax.Labels + ( -- * Overloaded labels + IsLabel(fromLabel) + , Label(..), LabelUsage(..) + -- * Infix operators + , (#=), (#=!), (.=), (%=) + ) + where + +-- base +import Data.Kind + ( Type ) +import qualified GHC.Stack + ( HasCallStack ) +import GHC.TypeLits + ( Symbol, KnownSymbol ) + +-- fir +import Control.Type.Optic + ( Optic, Name ) +import FIR.AST + ( Code ) +import FIR.Binding + ( Var, R, RW ) +import FIR.Module + ( Program ) +import FIR.Syntax.Program + ( def, use, assign, modifying ) +import FIR.Prim.Types + ( PrimTy ) +import FIR.ProgramState + ( ProgramState ) +import FIR.Validation.Bindings + ( ValidDef, AddBinding, Has, CanGet, CanPut ) + +-------------------------------------------------------------------------- +-- overloaded labels + +data Label (k :: Symbol) (a :: Type) = Label + +data LabelUsage + = Symbolic + | Use Symbol ProgramState + +class IsLabel k a (usage :: LabelUsage) v + | v -> a, usage v -> k, v k -> usage + where + fromLabel :: GHC.Stack.HasCallStack => v + +-- | Use a label symbolically. +-- +-- That is, @#foo@ stands for a standalone label. +instance ( KnownSymbol k + , PrimTy a + , usage ~ Symbolic + ) + => IsLabel k a usage (Label k a) where + fromLabel = Label @k @a + +-- | Use a label as a monadic value. +-- +-- That is, @#foo@ stands for the value bound at @"foo"@ +-- in the context of an indexed state monad. +instance ( KnownSymbol k + , PrimTy a + , a ~ Has k i + , CanGet k i + , r ~ Code a + , j ~ i + , usage ~ 'Use k i + ) + => IsLabel k a usage (Program i j r) where + fromLabel = use @(Name k :: Optic '[] i a) + +-------------------------------------------------------------------------- +-- infix operators + +infixr 1 #= +infixr 1 #=! +infixr 1 .= + +-- | Define a new variable using a label. +(#=) :: forall a k i. + ( GHC.Stack.HasCallStack + , KnownSymbol k + , ValidDef k i a + , PrimTy a + ) + => Label k a + -> Code a + -> Program i (AddBinding k (Var RW a) i) (Code a) +_ #= a = def @k @RW a + +-- | Define a new constant using a label. +(#=!) :: forall a k i. + ( GHC.Stack.HasCallStack + , KnownSymbol k + , ValidDef k i a + , PrimTy a + ) + => Label k a + -> Code a + -> Program i (AddBinding k (Var R a) i) (Code a) +_ #=! a = def @k @R a + +-- | Set the value of a variable with given label. +(.=) :: forall a k i. + ( GHC.Stack.HasCallStack + , KnownSymbol k + , a ~ Has k i + , CanPut k i + , PrimTy a + ) + => Label k a + -> Code a + -> Program i i (Code ()) +_ .= a = assign @(Name k :: Optic '[] i a) a + +-- | Modify a variable with given label using a function. +(%=) :: forall a k i. + ( GHC.Stack.HasCallStack + , KnownSymbol k + , a ~ Has k i + , CanGet k i + , CanPut k i + ) + => Label k a + -> (Code a -> Code a) + -> Program i i (Code ()) +_ %= f = modifying @(Name k :: Optic '[] i a) f diff --git a/src/FIR/Syntax/Optics.hs b/src/FIR/Syntax/Optics.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/Optics.hs @@ -0,0 +1,1020 @@ +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Syntax.Optics + +This module overloads 'Control.Type.Optic.view', +'Control.Type.Optic.set', and 'Control.Type.Optic.over' +to work with the AST, +in the way of getter/setter instances for types of the form @AST a@. + +For instance: + +> geometry = Module $ entrypoint @"main" @Geometry do +> gl_in <- use @(Name "gl_in") -- geometry shader built-in input (structure array) +> let pos0 = view @(Index 0 :.: Name "gl_Position") gl_in +> ... + +Singletons for optics are also provided, to assist in displaying +the names of optics, and internally for code generation. +-} + +module FIR.Syntax.Optics where + +-- base +import Data.Kind + ( Type, Constraint ) +import Data.Proxy + ( Proxy(Proxy) ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( Symbol, KnownSymbol, symbolVal + , TypeError + , ErrorMessage(Text, ShowType, (:<>:), (:$$:)) + ) +import GHC.TypeNats + ( Nat, KnownNat, natVal + , CmpNat, type (<=), type (-) + ) + +-- typelits-witnesses +import GHC.TypeLits.Compare + ( (:<=?)(LE), (%<=?) ) + +-- vector +import qualified Data.Vector as Unsized.Vector + ( (!), (//) ) + +-- vector-sized +import qualified Data.Vector.Sized as Vector + ( index, (//) ) + +-- fir +import Control.Monad.Indexed + ( (:=) ) +import Control.Type.Optic + ( Optic(..) + , Indices + , Gettable, ReifiedGetter(view) + , Settable, ReifiedSetter(set ) + , Container(..) + , (:.:), AnIndex, Name, OfType + , ProductComponents(..) + ) +import Data.Constraint.All + ( All ) +import Data.Function.Variadic + ( ListVariadic ) +import Data.Product + ( IsProduct, AreProducts + , Distribute + , MapHList + ) +import Data.Type.Known + ( Known ) +import Data.Type.LazyEquality + ( LazyEq ) +import Data.Type.List + ( type (:++:), ZipCons + , SLength, KnownLength(sLength) + , SSameLength, SameLength(sSameLength) + , Postpend + ) +import Data.Type.Map + ( (:->)((:->)) + , Key + ) +import FIR.Prim.Array + ( Array(..), RuntimeArray(..) ) +import FIR.Prim.Image + ( Image, ImageProperties + , ImageOperands, OperandName + ) +import FIR.Prim.Struct + ( Struct((:&)) + , HasStructField(getStructField, setStructField) + ) +import FIR.Prim.Types + ( PrimTy(primTySing) + , IntegralTy + , ScalarTy(scalarTySing), SScalarTy + , PrimTyMap + , SPrimTy(SStruct) + , HasOpaqueType + ) +import FIR.ProgramState + ( ProgramState ) +import qualified FIR.Validation.Bindings as Binding + ( Has, CanGet, CanPut ) +import FIR.Validation.Bounds + ( VectorIndexInBounds + , MatrixColumnIndexInBounds + , ArrayIndexInBounds + , StructFieldFromIndex, StructIndexFromName + ) +import FIR.Validation.Images + ( LookupImageProperties, ImageTexelType ) +import Math.Linear + ( V((:.)), M(M) + , (^!), at, replaceV + ) + +---------------------------------------------------------------------- +-- singletons + +-- | Singletons associated to the type-level optics used by this library. +data SOptic (optic :: Optic i s a) :: Type where + SOfType :: SPrimTy s -> SPrimTy a -> SOptic (OfType a :: Optic '[] s a) + -- for indices, we additional specify the accessee, to distinguish + -- the different methods SPIR-V supports for access: + -- - vectors with VectorExtractDynamic / VectorInsertDynamic + -- - arrays with OpAccessChain + SAnIndex :: SPrimTy s -> SPrimTy a -> SScalarTy ix -> SOptic (AnIndex ix :: Optic '[ix] s a) + SIndex :: SPrimTy s -> SPrimTy a -> Word32 -> SOptic (o :: Optic '[] s a) + -- we allow an overly-general return type for the above, + -- as we convert 'Name' optics to 'Index' optics behind the scenes + SBinding :: KnownSymbol k + => Proxy k + -> SOptic (Name k :: Optic '[] (as :: ProgramState) b) + SImageTexel :: ( KnownSymbol k + , Known ImageProperties props + ) + => Proxy k + -> Proxy props + -> SPrimTy (ImageTexelType props ops) + -> SOptic ( ( ( Field_ (k :: Symbol) :: Optic '[] i (Image props) ) + `ComposeO` + ( RTOptic_ :: Optic + '[ ImageOperands props ops, imgCds ] + (Image props) + (ImageTexelType props ops) + ) + ) :: Optic + '[ ImageOperands props ops, imgCds ] + i + (ImageTexelType props ops) + ) + SComposeO :: forall is js s a b (o1 :: Optic is s a) (o2 :: Optic js a b) + . SLength is -> SOptic o1 -> SOptic o2 -> SOptic (o1 :.: o2) + -- ^^^^^^^^^^ + -- we need to know the length of the first list to generate code for composite optics + -- see the function 'opticalTree' in the code generator + + -- similar remark applies to products + SProd :: forall + ( iss :: [[Type]] ) + ( k :: Type ) + ( s :: k ) + ( as :: [Type] ) + ( os :: ProductComponents iss s as) + ( js :: [Type] ) + ( p :: Type ) + . ( IsProduct p as + , AreProducts js iss as + , PrimTy p -- need to know result for SPIR-V code generation + , All PrimTy as + ) + => SSameLength (Distribute iss as) as + -> SProductComponents os + -> SOptic (Prod_ os :: Optic js s p) + +data SProductComponents (os :: ProductComponents iss s as) :: Type where + SEndProd :: SProductComponents EndProd_ + SProductO :: forall + ( k :: Type ) + ( is :: [Type] ) + ( s :: k ) + ( a :: Type ) + ( iss :: [[Type]] ) + ( as :: [Type] ) + ( o :: Optic is s a ) + ( os :: ProductComponents iss s as ) + . SameLength is iss + => SOptic o + -> SProductComponents os + -> SProductComponents (ProductO o os :: ProductComponents (ZipCons is iss) s (a ': as)) + +infixr 9 %:.: + +(%:.:) :: forall is js s a b (o1 :: Optic is s a) (o2 :: Optic js a b). + KnownLength is + => SOptic o1 -> SOptic o2 -> SOptic (o1 :.: o2) +o1 %:.: o2 = SComposeO (sLength @_ @is) o1 o2 + +showSOptic :: SOptic (o :: Optic is s a) -> String +showSOptic (SOfType _ sTy ) = "OfType " ++ show sTy +showSOptic (SAnIndex _ _ _) = "AnIndex" +showSOptic (SIndex _ _ n) = "Index " ++ show n +showSOptic (SBinding k ) = "Binding " ++ show (symbolVal k) +showSOptic (SImageTexel k _ _) = "ImageTexel " ++ show (symbolVal k) +showSOptic (SComposeO _ o1 o2) = showSOptic o1 ++ " :.: " ++ showSOptic o2 +showSOptic (SProd _ comps) = "Prod ( " ++ showSProductComponents comps ++ " )" + +showSProductComponents :: SProductComponents os -> String +showSProductComponents SEndProd = "EndProd" +showSProductComponents (o `SProductO` os) + = showSOptic o ++ " :*: " ++ showSProductComponents os + + +class KnownLength (Indices optic) => KnownOptic optic where + opticSing :: SOptic optic + +instance ( empty ~ '[] + , a ~ ty + , Container s + , PrimTy s + , PrimTy a + ) + => KnownOptic (OfType_ ty :: Optic empty s a) where + opticSing = SOfType (primTySing @s) (primTySing @a) +instance ( KnownNat n + , empty ~ '[] + , PrimTy s + , PrimTy a + ) + => KnownOptic (Field_ (n :: Nat) :: Optic empty s a) + where + opticSing = SIndex (primTySing @s) (primTySing @a) (fromIntegral . natVal $ Proxy @n) +instance forall (as :: [Symbol :-> Type]) (k :: Symbol) (a :: Type) + (empty :: [Type]) (i :: Nat) + . ( KnownSymbol k + , PrimTyMap as + , PrimTy a + , KnownNat i + , (i ':-> a) ~ StructIndexFromName k as + , empty ~ '[] + ) + => KnownOptic (Field_ (k :: Symbol) :: Optic empty (Struct as) a) + where + opticSing = SIndex (SStruct @Symbol @as) (primTySing @a) (fromIntegral . natVal $ Proxy @i) +instance ( KnownSymbol k + , empty ~ '[] + , a ~ Binding.Has k bds + ) + => KnownOptic (Field_ (k :: Symbol) :: Optic empty (bds :: ProgramState) a) + where + opticSing = SBinding (Proxy @k) +instance forall is js ks (s :: Type) a b (o1 :: Optic is s a) (o2 :: Optic js a b). + ( KnownOptic o1 + , KnownOptic o2 + , ks ~ (is :++: js) + , KnownLength is + , KnownLength js + , KnownLength ks -- deduced from the above two in concrete situations + ) + => KnownOptic ((o1 `ComposeO` o2) :: Optic ks s b) where + opticSing = (opticSing @o1) %:.: (opticSing @o2) +instance forall k is js ks (s :: ProgramState) a b + (o1 :: Optic is s a) (o2 :: Optic js a b) + . + ( KnownSymbol k + , o1 ~ ( Field_ k :: Optic is s a ) + , KnownOptic o2 + , KnownLength ks + , is ~ '[] + , ks ~ (is :++: js) + , a ~ Binding.Has k s + ) + => KnownOptic ( (o1 `ComposeO` o2) :: Optic ks s b ) where + opticSing = SBinding (Proxy @k) %:.: (opticSing @o2) +instance forall iss s as js p (os :: ProductComponents iss s as) + . ( KnownComponents os + , SameLength (Distribute iss as) as + , KnownLength js + , IsProduct p as + , AreProducts js iss as + , js ~ MapHList iss + , PrimTy p + , All PrimTy as + ) + => KnownOptic (Prod_ os :: Optic js s p) where + opticSing = SProd sSameLength (componentsSing @os) + +class KnownComponents os where + componentsSing :: SProductComponents os +instance ( as ~ '[] ) => KnownComponents ( EndProd_ :: ProductComponents iss s as ) where + componentsSing = SEndProd +instance forall + ( k :: Type ) + ( is :: [Type] ) + ( s :: k ) + ( a :: Type ) + ( iss :: [[Type]] ) + ( jss :: [[Type]] ) + ( as :: [Type] ) + ( o :: Optic is s a ) + ( os :: ProductComponents iss s as ) + . ( KnownOptic o + , KnownComponents os + , SameLength is iss + , jss ~ ZipCons is iss + ) + => KnownComponents (o `ProductO` os :: ProductComponents jss s (a ': as)) where + componentsSing = opticSing @o `SProductO` componentsSing @os + +-------------------------------------------------------------- +-- some trickery to account for peculiarities of image optics + +-- normal run-time index optic, not allowed to be used for images on its own +instance ( ValidAnIndexOptic is s a, is ~ '[ix], IntegralTy ix, PrimTy s, PrimTy a ) + => KnownOptic (RTOptic_ :: Optic is s a) + where + opticSing = SAnIndex (primTySing @s) (primTySing @a) (scalarTySing @ix) + + +-- binding + image texel optic... the two parts must always occur together +instance {-# OVERLAPPING #-} + forall + ( k :: Symbol ) + ( i :: ProgramState ) + ( props :: ImageProperties ) + ( ops :: [OperandName] ) + ( empty :: [Type] ) + ( imgOps :: Type ) + ( imgCds :: Type ) + ( imgTexel :: Type ) + . + ( KnownSymbol k + , PrimTy imgCds + , PrimTy imgTexel + , LookupImageProperties k i ~ props + , Known ImageProperties props + , imgOps ~ ImageOperands props ops + , imgTexel ~ ImageTexelType props ops + , empty ~ '[] + ) + => KnownOptic + ( ( ( Field_ (k :: Symbol) :: Optic empty i (Image props) ) + `ComposeO` + ( RTOptic_ :: Optic '[imgOps, imgCds] (Image props) imgTexel) + ) :: Optic '[imgOps, imgCds] i imgTexel + ) + where + opticSing = SImageTexel (Proxy @k) (Proxy @props) (primTySing @imgTexel) + +type family ValidAnIndexOptic (is :: [Type]) (s :: Type) (a :: Type) :: Constraint where + ValidAnIndexOptic '[] _ _ + = TypeError ( Text "Run-time optic does not specify the type of its run-time indices." ) + ValidAnIndexOptic _ (Image _) _ + = TypeError ( Text "Forbidden standalone image texel optic." + :$$: Text "Use the 'ImageTexel` optic, or an `imageRead`/`imageWrite` operation." + ) + ValidAnIndexOptic '[ix] _ _ = () + ValidAnIndexOptic is _ _ + = TypeError ( Text "Run-time optic specifies more than one type of index:" + :$$: Text " " :<>: ShowType is + ) + +---------------------------------------------------------------------- +-- Instances for compositions involving indexed monadic state. +-- These are provided for improved type inference, +-- by requiring that the part focused onto by the outer optic +-- is as dictated by the state. + +instance forall (k :: Symbol) (i :: ProgramState) empty js ks a b (o2 :: Optic js a b). + ( KnownSymbol k + , Gettable o2 + , empty ~ '[] + , ks ~ js + , a ~ Binding.Has k i -- this is the additional line that helps type inference + , Binding.CanGet k i + , NoOpaqueTypes "'get'/'use'" k b ( HasOpaqueType b ) + ) => Gettable ( ((Field_ (k :: Symbol) :: Optic empty i a) `ComposeO` o2) :: Optic ks i b ) + where +instance forall (k :: Symbol) (i :: ProgramState) empty js ks a b (o2 :: Optic js a b). + ( KnownSymbol k + , Settable o2 + , empty ~ '[] + , ks ~ js + , a ~ Binding.Has k i -- ditto + , Binding.CanPut k i + , NoOpaqueTypes "'put'/'assign'" k b ( HasOpaqueType b ) + ) => Settable ( ((Field_ (k :: Symbol) :: Optic empty i a) `ComposeO` o2) :: Optic ks i b ) + where + +type family NoOpaqueTypes ( msg :: Symbol ) ( k :: Symbol ) ( b :: Type ) ( hasOpaque :: Bool ) :: Constraint where + NoOpaqueTypes _ _ _ False = ( () :: Constraint ) + NoOpaqueTypes msg k b True = TypeError + ( Text msg :<>: Text ": cannot focus on type " + :$$: Text " " :<>: ShowType b + :$$: Text "within binding named " :<>: ShowType k :<>: Text ", as it is (or contains) an opaque type." + ) + +---------------------------------------------------------------------- + +type StatefulOptic (optic :: Optic is (s :: ProgramState) a) = ( () :: Constraint ) +-- to distinguish from (optic :: Optic is (s :: Type) a) + +type family ListVariadicIx + ( as :: [Type] ) + ( i :: ProgramState ) + ( b :: Type ) + = ( r :: Type ) + | r -> as i b where + ListVariadicIx '[] i b = (b := i) i + ListVariadicIx (a ': as) i b = a -> ListVariadicIx as i b + +---------------------------------------------------------------------- +-- getters + +type User (g :: Optic as i b) = ListVariadicIx as i b +type Viewer (g :: Optic is s a) = ListVariadic (is `Postpend` s) a + +-- bindings +instance ( KnownSymbol k + , r ~ Binding.Has k i + , Binding.CanGet k i + , empty ~ '[] + ) + => Gettable (Field_ (k :: Symbol) :: Optic empty (i :: ProgramState) r) where + + +instance + TypeError ( Text "get: cannot get a binding using a numeric index." + :$$: Text "Use the binding's name instead." + ) + => Gettable (Field_ (n :: Nat) :: Optic empty (i :: [Symbol :-> v]) r) + where + +-- arrays +instance ( KnownNat n, KnownNat i + , ArrayIndexInBounds n i + , r ~ a + , empty ~ '[] + ) + => Gettable (Field_ (i :: Nat) :: Optic empty (Array n a) r) where +instance ( KnownNat n, KnownNat i + , r ~ a + , empty ~ '[] + , PrimTy a + , Gettable (Field_ (i :: Nat) :: Optic empty (Array n a) r) + ) + => ReifiedGetter (Field_ (i :: Nat) :: Optic empty (Array n a) r) where + view (MkArray arr) = arr `Vector.index` fromIntegral (natVal (Proxy @i)) + +instance ( KnownNat i + , empty ~ '[] + , r ~ a + ) + => Gettable (Field_ (i :: Nat) :: Optic empty (RuntimeArray a) r) where +instance ( KnownNat n, KnownNat i + , empty ~ '[] + , r ~ a + , PrimTy a + ) + => ReifiedGetter (Field_ (i :: Nat) :: Optic empty (RuntimeArray a) r) where + view (MkRuntimeArray arr) = arr Unsized.Vector.! fromIntegral (natVal (Proxy @i)) + + +instance ( IntegralTy ty + , ix ~ '[ty] + , r ~ a + ) + => Gettable (RTOptic_ :: Optic ix (Array n a) r) where +instance ( KnownNat n + , IntegralTy ty + , ix ~ '[ty] + , r ~ a + , Gettable (RTOptic_ :: Optic ix (Array n a) r) + , PrimTy a + ) + => ReifiedGetter (RTOptic_ :: Optic ix (Array n a) r) where + view i (MkArray arr) = arr `Vector.index` fromIntegral i + +instance ( IntegralTy ty + , ix ~ '[ty] + , r ~ a + ) + => Gettable (RTOptic_ :: Optic ix (RuntimeArray a) r) where +instance ( IntegralTy ty, ix ~ '[ty], r ~ a, PrimTy a ) + => ReifiedGetter (RTOptic_ :: Optic ix (RuntimeArray a) r) where + view i (MkRuntimeArray arr) = arr Unsized.Vector.! fromIntegral i + +instance + TypeError ( Text "get: attempt to access array element \ + \using symbolic identifier " + :<>: ShowType k :<>: Text "." + ) + => Gettable (Field_ (k :: Symbol) :: Optic empty (Array n a) r) where + + +instance + TypeError ( Text "get: attempt to access run-time array \ + \element using symbolic identifier " + :<>: ShowType k :<>: Text "." + ) + => Gettable (Field_ (k :: Symbol) :: Optic empty (RuntimeArray a) r) where + + +-- structs +instance ( KnownSymbol k + , (n ':-> r) ~ StructIndexFromName k as + , empty ~ '[] + ) + => Gettable (Field_ (k :: Symbol) :: Optic empty (Struct as) r) where +instance ( KnownSymbol k + , HasStructField k r as + , (n ':-> r) ~ StructIndexFromName k as + , empty ~ '[] + , PrimTy r + ) + => ReifiedGetter + (Field_ (k :: Symbol) :: Optic empty (Struct as) r) + where + view = getStructField @k @r @as + +instance ( KnownNat n + , (k ':-> r) ~ StructFieldFromIndex n as + , empty ~ '[] + ) => Gettable (Field_ (n :: Nat) :: Optic empty (Struct as) r) where +instance ( KnownNat n + , empty ~ '[] + , PrimTy r + , HasStructField n r as + , (k ':-> r) ~ StructFieldFromIndex n as + ) + => ReifiedGetter + (Field_ (n :: Nat) :: Optic empty (Struct as) r) + where + view = getStructField @n @r @as + +instance + TypeError ( Text "get: attempt to access struct element \ + \using run-time index." + :$$: Text "Structs can only be accessed using \ + \compile-time indices, or field names." + ) + => Gettable (RTOptic_ :: Optic ix (Struct as) r) where + + +-- vectors +instance ( KnownNat i + , VectorIndexInBounds n i + , empty ~ '[] + ) + => Gettable (Field_ (i :: Nat) :: Optic empty (V n a) r) where +instance ( KnownNat n + , KnownNat i + , VectorIndexInBounds n i + , empty ~ '[] + , PrimTy a + , CmpNat i n ~ 'LT + , r ~ a + ) + => ReifiedGetter + (Field_ (i :: Nat) :: Optic empty (V n a) r) + where + view v = at @i v + +instance ( IntegralTy ty + , ix ~ '[ty] + , r ~ a + ) + => Gettable (RTOptic_ :: Optic ix (V n a) r) where +instance ( IntegralTy ty + , r ~ a + , ix ~ '[ty] + , PrimTy a + ) + => ReifiedGetter + (RTOptic_ :: Optic ix (V n a) r) + where + view i v = v ^! fromIntegral i + + +instance + TypeError ( Text "get: attempt to access vector element \ + \using symbolic identifier " + :<>: ShowType k :<>: Text "." + :$$: Text "For a vector swizzle, use 'Swizzle' (e.g. Swizzle '[\"x\",\"z\",\"y\"])," + :$$: Text "or a synonym such as XZY (limited to X/Y/Z/W)." + ) + => Gettable (Field_ (k :: Symbol) :: Optic empty (V n a) r) where + + +-- matrices +instance ( KnownNat n + , KnownNat i + , r ~ V m a + , MatrixColumnIndexInBounds m n i + , empty ~ '[] + ) + => Gettable (Field_ (i :: Nat) :: Optic empty (M m n a) r) where +instance ( KnownNat m + , KnownNat n + , KnownNat i + , MatrixColumnIndexInBounds m n i + , r ~ V m a + , CmpNat i n ~ 'LT + , empty ~ '[] + ) + => ReifiedGetter + (Field_ (i :: Nat) :: Optic empty (M m n a) r) + where + view (M cols) = at @i cols + +instance ( IntegralTy ty + , ix ~ '[ty] + , r ~ V m a + ) + => Gettable (RTOptic_ :: Optic ix (M m n a) r) where +instance ( KnownNat m + , KnownNat n + , IntegralTy ty + , r ~ V m a + , ix ~ '[ty] + ) + => ReifiedGetter + (RTOptic_ :: Optic ix (M m n a) r) + where + view i (M cols) = cols ^! fromIntegral i + + +instance + TypeError ( Text "get: attempt to access matrix column \ + \using symbolic identifier " + :<>: ShowType k :<>: Text "." + ) + => Gettable (Field_ (k :: Symbol) :: Optic empty (M m n a) r) where + +---------------------------------------------------------------------- +-- setters + +type Assigner (g :: Optic as i b) = ListVariadicIx (as `Postpend` b) i () +type Setter (g :: Optic is s a) = ListVariadic (is `Postpend` a `Postpend` s) s + + +-- bindings +instance ( KnownSymbol k + , r ~ Binding.Has k i + , Binding.CanPut k i + , empty ~ '[] + ) + => Settable (Field_ (k :: Symbol) :: Optic empty (i :: ProgramState) r ) where + + + +instance + TypeError ( Text "set: cannot set binding using a numeric index." + :$$: Text "Use the binding's name instead." + ) + => Settable (Field_ (n :: Nat) :: Optic empty (i :: [Symbol :-> v]) r) where + +-- arrays +instance ( KnownNat n, KnownNat i + , ArrayIndexInBounds n i + , empty ~ '[] + , r ~ a + ) + => Settable (Field_ (i :: Nat) :: Optic empty (Array n a) r) where +instance ( KnownNat n, KnownNat i + , r ~ a + , empty ~ '[] + , Settable (Field_ (i :: Nat) :: Optic empty (Array n a) r) + ) + => ReifiedSetter + (Field_ (i :: Nat) :: Optic empty (Array n a) r) + where + set a (MkArray arr) = MkArray ( arr Vector.// [( fromIntegral (natVal (Proxy @i)), a)] ) + +instance ( KnownNat i + , empty ~ '[] + , r ~ a + ) + => Settable (Field_ (i :: Nat) :: Optic empty (RuntimeArray a) r) where +instance ( KnownNat i + , empty ~ '[] + , r ~ a + , PrimTy a + ) + => ReifiedSetter + (Field_ (i :: Nat) :: Optic empty (RuntimeArray a) r) + where + set a (MkRuntimeArray arr) + = MkRuntimeArray ( arr Unsized.Vector.// [( fromIntegral (natVal (Proxy @i)), a)] ) + +instance ( IntegralTy ty + , ix ~ '[ty] + , r ~ a + ) + => Settable (RTOptic_ :: Optic ix (Array n a) r) where +instance ( KnownNat n + , IntegralTy ty + , r ~ a + , ix ~ '[ty] + , Settable (RTOptic_ :: Optic ix (Array n a) r) + ) + => ReifiedSetter + (RTOptic_ :: Optic ix (Array n a) r) + where + set i a (MkArray arr) = MkArray ( arr Vector.// [(fromIntegral i, a)] ) + +instance ( IntegralTy ty + , ix ~ '[ty] + , r ~ a + ) + => Settable (RTOptic_ :: Optic ix (RuntimeArray a) r) where +instance ( IntegralTy ty + , ix ~ '[ty] + , r ~ a + , PrimTy a + ) + => ReifiedSetter + (RTOptic_ :: Optic ix (RuntimeArray a) r) + where + set i a (MkRuntimeArray arr) + = MkRuntimeArray ( arr Unsized.Vector.// [(fromIntegral i, a)] ) + +instance + TypeError ( Text "set: attempt to update array element \ + \using symbolic identifier " + :<>: ShowType k :<>: Text "." + ) + => Settable (Field_ (k :: Symbol) :: Optic empty (Array n a) r) where + +instance + TypeError ( Text "set: attempt to update run-time array \ + \element using symbolic identifier " + :<>: ShowType k :<>: Text "." + ) + => Settable (Field_ (k :: Symbol) :: Optic empty (RuntimeArray a) r) where + +-- structs +instance ( KnownSymbol k + , (n ':-> r) ~ StructIndexFromName k as + , empty ~ '[] + ) + => Settable (Field_ (k :: Symbol) :: Optic empty (Struct as) r) where +instance ( KnownSymbol k + , HasStructField k r as + , (n ':-> r) ~ StructIndexFromName k as + , empty ~ '[] + ) + => ReifiedSetter + (Field_ (k :: Symbol) :: Optic empty (Struct as) r) + where + set = setStructField @k @r @as + +instance ( KnownNat n + , (k ':-> r) ~ StructFieldFromIndex n as + , empty ~ '[] + ) => Settable (Field_ (n :: Nat) :: Optic empty (Struct as) r) where +instance ( KnownNat n + , HasStructField n r as + , (k ':-> r) ~ StructFieldFromIndex n as + , empty ~ '[] + ) + => ReifiedSetter + (Field_ (n :: Nat) :: Optic empty (Struct as) r) + where + set = setStructField @n @r @as + +instance + TypeError ( Text "set: attempt to set struct element \ + \using run-time index." + :$$: Text "Structs can only be modified using \ + \compile-time indices or field names." + ) + => Settable (RTOptic_ :: Optic ix (Struct as) r) where + +-- vectors +instance ( KnownNat i + , VectorIndexInBounds n i + , empty ~ '[] + ) + => Settable (Field_ (i :: Nat) :: Optic empty (V n a) r) where +instance ( KnownNat n, KnownNat i, 1 <= n + , CmpNat i n ~ 'LT + , r ~ a + , empty ~ '[] + , VectorIndexInBounds n i + ) + => ReifiedSetter + (Field_ (i :: Nat) :: Optic empty (V n a) r) + where + set = replaceV ( fromIntegral ( natVal ( Proxy @i ) ) ) + +instance ( IntegralTy ty + , ix ~ '[ty] + , r ~ a + , KnownNat n, 1 <= n + ) + => Settable (RTOptic_ :: Optic ix (V n a) r) where +instance ( IntegralTy ty + , ix ~ '[ty] + , r ~ a + , KnownNat n, 1 <= n + ) + => ReifiedSetter (RTOptic_ :: Optic ix (V n a) r) where + set 0 b (_ :. as) = b :. as + set i b (a :. as) = case Proxy @1 %<=? Proxy @(n-1) of + LE Refl -> a :. set @(RTOptic_ :: Optic ix (V (n-1) a) r) (i-1) b as + _ -> a :. as + +instance + TypeError ( Text "set: attempt to update vector element \ + \using symbolic identifier " + :<>: ShowType k :<>: Text "." + :$$: Text "For a vector swizzle, use 'Swizzle' (e.g. Swizzle '[\"x\",\"z\",\"y\"])," + :$$: Text "or a synonym such as XZY (limited to X/Y/Z/W)." + ) + => Settable (Field_ (k :: Symbol) :: Optic empty (V n a) r) where + +-- matrices +instance ( KnownNat i + , empty ~ '[] + , MatrixColumnIndexInBounds m n i + ) + => Settable (Field_ (i :: Nat) :: Optic empty (M m n a) r) where +instance ( KnownNat m, KnownNat n, KnownNat i, 1 <= n + , empty ~ '[] + , r ~ V m a + , MatrixColumnIndexInBounds m n i + ) + => ReifiedSetter + (Field_ (i :: Nat) :: Optic empty (M m n a) r) + where + set c (M m) = M $ replaceV ( fromIntegral ( natVal ( Proxy @i ) ) ) c m + +instance ( IntegralTy ty + , ix ~ '[ty] + , r ~ V m a + ) + => Settable (RTOptic_ :: Optic ix (M m n a) r) where +instance ( IntegralTy ty + , ix ~ '[ty] + , r ~ V m a + , KnownNat m, KnownNat n, 1 <= n + ) + => ReifiedSetter (RTOptic_ :: Optic ix (M m n a) r) + where + set i c (M m) + = ( M + . set @(RTOptic_ :: Optic ix (V n (V m a)) (V m a)) i c + ) m + +instance + TypeError ( Text "set: attempt to update matrix column \ + \using symbolic identifier " + :<>: ShowType k :<>: Text "." + ) + => Settable (Field_ (k :: Symbol) :: Optic empty (M m n a) r) where + + +---------------------------------------------------------------------- +-- type class instances for containers + +instance Container (Array n a) where +instance Container (RuntimeArray a) where +instance KnownNat n => Container (M m n a) where +instance Container (V n a) where + type FieldIndexFromName (V n a) k + = TypeError ( Text "optic: attempt to index a vector component with name " :<>: ShowType k + :$$: Text "Maybe you intended to use a swizzle?" + ) +instance Container (Struct (as :: [Symbol :-> Type])) where + type FieldIndexFromName (Struct (as :: [Symbol :-> Type])) k + = Key (StructIndexFromName k as) + +---------------------------------------------------------------------- +-- type class instances for "OfType" optic + +-- vectors +class SetVector n a b (a_eq_b :: Bool) where + setVector :: b -> V n a -> V n a +instance (a ~ b, KnownNat n) => SetVector n a b 'True where + setVector a _ = pure a +instance SetVector n a b 'False where + setVector _ = id + +instance ( empty ~ '[] + , KnownNat n + , SetVector n a b (a `LazyEq` b) + ) + => Settable (OfType_ ty :: Optic empty (V n a) b) + where +instance ( empty ~ '[] + , b ~ a + , KnownNat n + , SetVector n a b (a `LazyEq` b) + ) + => ReifiedSetter (OfType_ ty :: Optic empty (V n a) b) + where + set = setVector @n @a @b @(a `LazyEq` b) + +-- matrices +data MatrixComponent + = Column + | Entry + +type family WhichMatrixComponent + (m :: Nat) (a :: Type) (b :: Type) + :: Maybe MatrixComponent + where + WhichMatrixComponent _ a a = Just Entry + WhichMatrixComponent m a (V m a) = Just Column + WhichMatrixComponent _ _ _ = Nothing + +class SetMatrix m n a b (w :: Maybe MatrixComponent) where + setMatrix :: b -> M m n a -> M m n a +instance ( b ~ a + , KnownNat m + , KnownNat n + ) + => SetMatrix m n a b (Just Entry) where + setMatrix a _ = pure a +instance ( b ~ V m a + , KnownNat m + , KnownNat n + ) + => SetMatrix m n a b (Just Column) where + setMatrix col _ = M ( pure col :: V n (V m a) ) +instance SetMatrix m n a b Nothing where + setMatrix _ = id + +instance ( empty ~ '[] + , KnownNat m + , KnownNat n + , b ~ ty + , SetMatrix m n a b (WhichMatrixComponent m a b) + ) + => Settable (OfType_ ty :: Optic empty (M m n a) b) + where +instance ( empty ~ '[] + , KnownNat m + , KnownNat n + , b ~ ty + , SetMatrix m n a b (WhichMatrixComponent m a b) + ) + => ReifiedSetter (OfType_ ty :: Optic empty (M m n a) b) + where + set = setMatrix @m @n @a @b @(WhichMatrixComponent m a b) + +-- arrays +instance ( empty ~ '[] + , KnownNat n + , b ~ ty + , Settable (OfType ty :: Optic '[] a ty) + ) + => Settable (OfType_ ty :: Optic empty (Array n a) b) + where +instance ( empty ~ '[] + , KnownNat n + , b ~ ty + , ReifiedSetter (OfType ty :: Optic '[] a ty) + , ListVariadic '[] a ~ a + ) + => ReifiedSetter (OfType_ ty :: Optic empty (Array n a) b) + where + set a = fmap ( set @(OfType ty :: Optic '[] a ty) a ) + +instance ( TypeError ( Text "Cannot use 'OfType' optic on a runtime array." ) ) + => Settable (OfType_ ty :: Optic empty (RuntimeArray a) r) + where +instance ( TypeError ( Text "Cannot use 'OfType' optic on a runtime array." ) ) + => ReifiedSetter (OfType_ ty :: Optic empty (RuntimeArray a) r) + where + set = error "unreachable" + +-- structs +instance ( empty ~ '[] ) => Settable (OfType_ ty :: Optic empty (Struct '[]) b) where +instance ( empty ~ '[] ) => ReifiedSetter (OfType_ ty :: Optic empty (Struct '[]) b) where + set _ = id +instance ( empty ~ '[] + , Settable (OfType ty :: Optic '[] a ty) + , Settable (OfType ty :: Optic '[] (Struct as) ty) + , b ~ ty + ) + => Settable ( OfType_ ty :: Optic empty (Struct ( (fld ':-> a) ': as ) ) b ) where +instance ( empty ~ '[] + , ReifiedSetter (OfType ty :: Optic '[] a ty) + , ReifiedSetter (OfType ty :: Optic '[] (Struct as) ty) + , b ~ ty + , ListVariadic '[] a ~ a + ) + => ReifiedSetter ( OfType_ ty :: Optic empty (Struct ( (fld ':-> a) ': as ) ) b ) where + set x ( a :& as ) + = set @(OfType ty :: Optic '[] a b) x a + :& set @(OfType ty :: Optic '[] (Struct as) b) x as diff --git a/src/FIR/Syntax/Optics.hs-boot b/src/FIR/Syntax/Optics.hs-boot new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/Optics.hs-boot @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RoleAnnotations #-} + +module FIR.Syntax.Optics where + +-- base +import Data.Kind + ( Type ) + +-- fir +import {-# SOURCE #-} Control.Type.Optic + ( Optic + , Indices + ) +import Data.Type.List + ( KnownLength ) + +---------------------------------------------------------------------- + +data SOptic (optic :: Optic i s a) :: Type +type role SOptic nominal + +class KnownLength (Indices optic) => KnownOptic optic where + opticSing :: SOptic optic + +showSOptic :: SOptic (o :: Optic is s a) -> String diff --git a/src/FIR/Syntax/Option.hs b/src/FIR/Syntax/Option.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/Option.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Syntax.Option + +Custom 'Option' type (like 'Maybe') and associated functionality. +-} + +module FIR.Syntax.Option + ( Option(..) + , some, none + , option, fromOption + ) + where + +-- base +import Prelude hiding ((&&)) +import Control.Monad + ( ap ) + +-- fir +import Control.Type.Optic + ( Name, ReifiedGetter(view) ) +import Data.Type.Map + ( (:->)((:->)) ) +import FIR.AST + ( Code + , Syntactic(..) + , SyntacticVal, InternalType + , pattern Lit, pattern Undefined, pattern Struct + ) +import FIR.AST.Type + ( AugType(Val) ) +import FIR.Prim.Struct + ( Struct(..) ) +import FIR.Prim.Types + ( PrimTy ) +import FIR.Syntax.AST + ( ) +import FIR.Syntax.IfThenElse + ( ) +import FIR.Syntax.Program + ( ) +import Math.Logic.Class + ( Choose(..), Boolean((&&)) ) + +-------------------------------------------------------------------------------------- + +-- | 'Option' type like in Axelsson–Svenningsson. +data Option a = Option { isSome :: Code Bool, fromSome :: a } + deriving stock Functor +instance Applicative Option where + pure = some + (<*>) = ap +instance Monad Option where + return = pure + Option { isSome = c, fromSome = a } >>= f + | Option { isSome = d, fromSome = b } <- f a + = Option { isSome = c && d, fromSome = b } + +instance ( SyntacticVal a, PrimTy (InternalType a) ) => Syntactic (Option a) where + type Internal (Option a) = + Val (Struct '[ "isSome" ':-> Bool, "fromSome" ':-> InternalType a ]) + toAST (Option { isSome = c, fromSome = a }) + = choose c + ( Struct ( Lit True :& toAST a :& End ) ) + ( Struct ( Lit False :& Undefined :& End ) ) + fromAST struct + = Option + { isSome = view @(Name "isSome" ) struct + , fromSome = fromAST (view @(Name "fromSome") struct) + } +some :: a -> Option a +some a = Option { isSome = Lit True, fromSome = a } +none :: forall a. ( SyntacticVal a, PrimTy (InternalType a) ) => Option a +none = Option { isSome = Lit False, fromSome = fromAST $ Undefined @(InternalType a) } +option + :: ( SyntacticVal a + , PrimTy (InternalType a) + , Choose (Code Bool) '(b,b,b) + ) + => b -> (a -> b) -> Option a -> b +option b f a_opt = + choose ( isSome a_opt ) ( f ( fromSome a_opt ) ) b + +fromOption :: ( SyntacticVal a, PrimTy (InternalType a), Choose (Code Bool) '(a,a,a) ) + => a -> Option a -> a +fromOption a = option a id diff --git a/src/FIR/Syntax/Program.hs b/src/FIR/Syntax/Program.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/Program.hs @@ -0,0 +1,1455 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +{-| +Module: FIR.Syntax.Program + +This module, together with "FIR.Syntax.AST", +provides most of the user-facing syntax for constructing +and manipulating values in the EDSL. + +This is done through type class overloading, here in the form of +orphan instances for types of the form @Program (i :: ProgramState) (j :: ProgramState) (a :: Type)@, +representing stateful values in the EDSL. +See also "FIR.ProgramState". + +Recall that 'Program' is a wrapper for the internal representation +using the indexed codensity transformation, see "FIR.Module". + +See also the validation modules: + + * "FIR.Validation.Bindings" for stateful operations such as 'get'/'put', + and definitions (of variables, functions, entrypoints). + * "FIR.Validation.Images" for image read/write operations such as + 'imageRead'/'imageWrite'. + +-} + +module FIR.Syntax.Program + ( -- * Monadic control operations + while, loop, break, breakContinue, continue + , switchM, locally, embed, purely + + -- * Stateful operations (with indexed monadic state) + -- ** Defining new objects + -- *** Constants / variables + , let', def, def' + -- *** Functions + , fundef + -- *** Entry points + , entryPoint, shader + + -- ** Optics + -- *** General functions: use, assign, modifying + , use, assign, modifying + -- *** Special cases for manipulating variables + , get, put, modify + -- *** Special cases for manipulating images + , imageRead, imageWrite + -- *** Atomic operations + -- $atomics + , atomicLoad, atomicStore + , atomicExchange, atomicCompareExchange + , atomicIncrement, atomicDecrement + , atomicAdd, atomicSub, atomicMin, atomicMax + , atomicAnd, atomicOr, atomicXor + , ProgExchanger, ProgCompareExchanger + + -- * Querying the length of a run-time array + , ArrayLength, arrayLength + + -- * Geometry shader primitive instructions + , emitVertex, endPrimitive + + -- * Memory synchronisation primitive operations + , controlBarrier, memoryBarrier + + -- * Group operations + , HasGroupAdd(..) + , HasGroupMul(..) + , HasGroupMinMax(..) + , HasGroupBitwise(..) + , HasGroupLogic(..) + + -- * Instances + + -- ** Undefined type class + -- $undef + + -- ** Logical operations + -- $logical + + -- ** Numeric operations + -- $numeric + + -- ** Numeric conversions + -- $conversions + + -- ** Vectors + -- $vectors + + -- ** Matrices + -- $matrices + + -- + orphan instances + ) + where + +-- base +import Prelude hiding + ( Eq(..), (&&), (||), not + , Ord(..) + , Num(..), Floating(..), RealFrac(..) + , Integral(..) + , Fractional(..), fromRational + , Floating(..), RealFloat(..) + , Functor(..), Monad(..) + , Applicative(..) + , break, undefined + ) +import qualified Prelude +import Data.Kind + ( Type ) +import Data.Maybe + ( fromMaybe ) +import Data.Proxy + ( Proxy(Proxy) ) +import Data.Word + ( Word32 ) +import qualified GHC.Stack + ( HasCallStack ) +import GHC.TypeLits + ( Symbol, KnownSymbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat, KnownNat ) + +-- fir +import CodeGen.Instruction + ( ID(..) ) +import Control.Monad.Indexed + ( (:=)(AtKey), Codensity(Codensity) + , MonadIxFail(fail) + , ixFmap, ixPure, ixLiftA2 + ) +import qualified Control.Monad.Indexed as Indexed +import Control.Type.Optic + ( Optic(..), Name, Gettable, Settable + , Part, Whole, Indices + ) +import Data.Constraint.All + ( All ) +import Data.Type.Known + ( Known, knownValue ) +import Data.Type.List + ( KnownLength(sLength), Postpend ) +import Data.Type.Map + ( (:->)((:->)), Map ) +import FIR.AST + ( AST, Code + , Syntactic(Internal,toAST,fromAST) + , SyntacticVal, InternalType + , primOp + , pattern MkID + , HasUndefined(undefined) + , AugUser, AugAssigner, AugExchanger, AugCompareExchanger + , FunctionHandle + , pattern Lam, pattern (:$), pattern Lit + , pattern Locally, pattern Embed + , pattern While, pattern Loop, pattern Break, pattern BreakContinue + , pattern SwitchM + , pattern Bind + , pattern Let, pattern Def, pattern FunDef, pattern FunCall, pattern DefEntryPoint + , pattern ArrayLength + , pattern Use, pattern Assign, pattern Atomic + , pattern NilOps + ) +import FIR.AST.Type + ( AugType(Val), Eff, FunArgs, Nullary ) +import FIR.Binding + ( BindingsMap, Var, Permissions + , FunctionAugType + ) +import FIR.Definition + ( Definition, KnownDefinitions + , StartState + , StartBindings, EndBindings + ) +import FIR.Module + ( Program + , ShaderModule(ShaderModule) + ) +import FIR.Prim.Array + ( RuntimeArray ) +import FIR.Prim.Image + ( ImageProperties, ImageOperands + ) +import FIR.Prim.RayTracing + ( RayQueryState ) +import FIR.Prim.Struct + ( Struct ) +import FIR.Prim.Op + ( Vectorise(Vectorise) ) +import FIR.Prim.Atomic + ( SAtomicOp(..), AtomicTy, AtomicIntegralTy ) +import FIR.Prim.Types + ( PrimTy, ScalarTy, IntegralTy + , KnownVars + , primTy + ) +import FIR.ProgramState + ( CFGState(..) + , FunctionInfo + , FunctionContext(..) + , ProgramState(ProgramState) + , TLInterface + , ExecutionContext + , EntryPointInfo + ) +import FIR.Syntax.AST + ( ) +import FIR.Syntax.Images + ( ImageTexel ) +import FIR.Syntax.Optics + ( KnownOptic, opticSing + , StatefulOptic + ) +import FIR.Validation.Bindings + ( ValidDef, AddBinding, Has + , ValidFunDef, AddFunBinding, FunctionTypes + , FunctionDefinitionStartState, FunctionDefinitionEndState + , ValidEntryPoint + , EntryPointStartState, EntryPointEndState + , SetInterface, GetExecutionInfo + , Embeddable + ) +import FIR.Validation.Bounds + ( StructIndexFromName ) +import FIR.Validation.CFG + ( InLoop + , ValidBreak, ValidContinue + ) +import FIR.Validation.Definitions + ( ValidDefinitions ) +import FIR.Validation.Images + ( LookupImageProperties, ImageTexelType + , ValidImageRead, ValidImageWrite + ) +import Math.Algebra.Class + ( AdditiveMonoid(..), CancellativeAdditiveMonoid(..), AdditiveGroup(..) + , Semiring(..), Ring + , DivisionRing(..) + , Signed(..), Archimedean(..) + , Floating(..), RealFloat(..) + , Convert(..), Rounding(..) + ) +import Math.Linear + ( Semimodule(..), LinearModule(..) + , Inner(..), Cross(..) + , Matrix(..), VectorOf + , V, M + ) +import Math.Logic.Bits + ( Bits(..), BitShift(..), BitCast(..) ) +import Math.Logic.Class + ( Eq(..), Boolean(..), Ord(..) ) +import qualified SPIRV.Groups as SPIRV + ( GroupOperation(..), groupOperationToWord32 ) +import qualified SPIRV.PrimOp as SPIRV + ( GeomPrimOp(..), SyncPrimOp(..) + , GroupNumOp(..), GroupBitwiseOp(..), GroupLogicOp(..) + ) +import qualified SPIRV.Stage as SPIRV +import qualified SPIRV.Synchronisation as SPIRV + ( SynchronisationScope, MemorySemantics + , synchronisationScope, memorySemanticsBitmask + ) +-------------------------------------------------------------------------- +-- * Monadic control operations + +-- | Encapsulate local state, turning a program which changes state +-- into one that preserves state. +locally :: forall i j r. (SyntacticVal r) => Program i j r -> Program i i r +locally p = fromAST ( Locally :$ toAST p ) + +-- | Embed a program with a /smaller/ state into one with a /larger/ state. +embed :: forall i j r. (Embeddable i j, SyntacticVal r) + => Program i i r -> Program j j r +embed p = fromAST ( Embed :$ toAST p ) + +-- | Take a stateless program and embed it into another program. +purely + :: ( SyntacticVal r + , i ~ 'ProgramState '[] 'TopLevel ('CFGState 0) '[] '[] '[] '[] bkend + , Embeddable i k + ) + => Program i j r -> Program k k r +purely = embed . locally + +-- | While loop: loop over the body as long as the condition is true. +-- +-- The condition is checked before the first time around the loop. +while :: GHC.Stack.HasCallStack + => Program i i (Code Bool) -- ^ Condition. + -> Program (InLoop i) j (Code ()) -- ^ Loop body. + -> Program i i (Code ()) +while c p = fromAST ( While :$ toAST c :$ toAST p ) + +-- | Unconditional loop. Break out of the loop using 'break'. +loop :: GHC.Stack.HasCallStack + => Program (InLoop i) j (Code ()) + -> Program i i (Code ()) +loop p = fromAST ( Loop :$ toAST p ) + +-- | Break out of the given number of loops (specified with a type application). +-- +-- Usage: @break \@n@ breaks out of the @n@ innermost loops at the current stage. +break :: forall ( n :: Nat ) ( i :: ProgramState ) + . ( GHC.Stack.HasCallStack + , KnownNat n, ValidBreak n i + ) + => Program i i (Code ()) +break = fromAST ( Break ( Proxy @n ) ) + +-- | Break out the given number of loops (possibly @0@), +-- and then continue from the start of the remaining innermost loop, +-- checking the loop header condition if there is one. +-- +-- Usage: @breakContinue \@i@. +breakContinue + :: forall ( n :: Nat ) ( i :: ProgramState ) + . ( GHC.Stack.HasCallStack + , KnownNat n, ValidContinue n i + ) + => Program i i (Code ()) +breakContinue = fromAST ( BreakContinue ( Proxy @n ) ) + +-- | Go back to the start of the current loop, +-- checking the loop header condition if there is one. +continue :: ( GHC.Stack.HasCallStack, ValidContinue 0 i ) => Program i i (Code ()) +continue = breakContinue @0 + +-- | Monadic switch statement. +-- Takes a scrutinee, a list of cases and a default (fallthrough) case. +-- +-- Returns a switch statement which decides on the branch to follow by inspecting the scrutinee. +-- +-- See 'FIR.Syntax.AST.switch' for a non-monadic version. +switchM :: ( Syntactic scrut, Internal scrut ~ Val vscrut + , IntegralTy vscrut + , Syntactic val, Internal val ~ Val vval + , PrimTy vval + ) + => Program i i scrut -- ^ Scrutinee. + -> [ InternalType scrut :-> Program i i val ] -- ^ Cases. + -> Program i i val -- ^ Default (fallthrough) case. + -> Program i i val +switchM scrut cases val = fromAST $ SwitchM (toAST scrut) (toAST val) (map ( \ (x :-> y) -> (x, toAST y) ) cases) + +-------------------------------------------------------------------------- +-- Undefined + +-- $undef +-- Instance for the 'Undefined' type class. + +-- Enforcing "i ~ j" allows the user to use 'undefined' in indexed-monadic code +-- without wreaking havoc on type inference by causing the computation to result +-- in an arbitrary state. +-- This does mean that the user cannot use 'undefined' to stand-in for an +-- arbitrary state-changing computation. +instance ( PrimTy a, j ~ i ) => HasUndefined (Program i j (Code a)) where + undefined = ixPure undefined + +instance {-# OVERLAPPABLE #-} ( j ~ i ) => HasUndefined (Program i j a) where + undefined = Prelude.undefined + +-------------------------------------------------------------------------- +-- Stateful operations (with indexed monadic state) + +-- Defining functions and variables. + +-- | let binding. +let' :: forall ( a :: Type ) ( i :: ProgramState ) + . ( GHC.Stack.HasCallStack, SyntacticVal a, PrimTy (InternalType a) ) + => a + -> Program i i a +let' = fromAST Let + +-- | Define a new variable. +-- +-- Type-level arguments: +-- +-- *@k@: name to use for definition, +-- *@ps@: 'FIR.Binding.Permission's (readable, writable, ...), +-- *@a@: type of definition, +-- *@i@: state at start of definition (usually inferred). +def :: forall + ( k :: Symbol ) + ( ps :: Permissions ) + ( a :: Type ) + ( i :: ProgramState ) + . ( GHC.Stack.HasCallStack + , KnownSymbol k + , Known Permissions ps + , PrimTy a + , ValidDef k i a + ) + => Code a -- ^ Initial value. + -> Program i (AddBinding k (Var ps a) i) (Code a) +def = fromAST ( Def (Proxy @k) (Proxy @ps) ) + +-- | Define a new variable, using `Syntactic` for desugaring. +-- +-- Type-level arguments: +-- +-- *@k@: name to use for definition, +-- *@ps@: 'FIR.Binding.Permission's (readable, writable, ...), +-- *@a@: type of definition, +-- *@i@: state at start of definition (usually inferred). +def' :: forall + ( k :: Symbol ) + ( ps :: Permissions ) + ( a :: Type ) + ( i :: ProgramState ) + . ( GHC.Stack.HasCallStack + , KnownSymbol k + , Known Permissions ps + , SyntacticVal a, PrimTy (InternalType a) + , ValidDef k i (InternalType a) + ) + => a -- ^ Initial value. + -> Program i (AddBinding k (Var ps (InternalType a)) i) a +def' = fromAST ( Def (Proxy @k) (Proxy @ps) ) + +-- | Define a new function. +-- +-- Type-level arguments: +-- +-- * @name@: function name, +-- * @as@: list of argument types, +-- * @b@: return type, +-- * @j_bds@: bindings state at end of function body (usually inferred), +-- * @i@: monadic state at start of function body (usually inferred), +-- * @r@: function type itself, result of 'fundef' (usually inferred). +fundef :: forall + ( name :: Symbol ) + ( as :: BindingsMap ) + ( b :: Type ) + ( j_bds :: BindingsMap ) + ( i :: ProgramState ) + ( r :: Type ) + . ( GHC.Stack.HasCallStack + , Syntactic r + , Internal r ~ FunctionAugType as b, All Nullary (FunArgs (FunctionAugType as b)) + , KnownSymbol name + , KnownVars as + , PrimTy b + , ValidFunDef name as i j_bds + , '(as, b) ~ FunctionTypes name i + ) + => Program + ( FunctionDefinitionStartState name as i ) + ( FunctionDefinitionEndState name as j_bds i ) + ( Code b ) -- ^ Function body code. + -> Program i (AddFunBinding name as b i) r +fundef f = ixFmap ( \g -> fromAST ( FunCall (Proxy @name) ( Proxy @as ) ( Proxy @b ) :$ g ) ) cod + where + fun :: AST (Eff i (AddFunBinding name as b i) (FunctionHandle name as b)) + fun = FunDef (Proxy @name) (Proxy @as) (Proxy @b) :$ toAST f + cod :: Program i (AddFunBinding name as b i) (AST (Val (FunctionHandle name as b))) + cod = Codensity ( \k -> Bind :$ fun :$ Lam (k . AtKey) ) + +-- | Define a new entry point. +-- +-- The appropriate built-in variables are made available in the entry point body. +-- +-- Type-level arguments: +-- +-- *@name@: name of entry point, +-- *@stage@: entry point 'SPIRV.Stage.ExecutionModel', +-- *@stageInfo@: entry point 'SPIRV.Stage.ExecutionInfo' (usually inferred), +-- *@j_bds@: bindings state at end of entry point body (usually inferred), +-- *@j_iface@: interface of entry point (usually inferred), +-- *@i@: state at start of entry point body (usually inferred). +entryPoint :: forall + ( name :: Symbol ) + ( stage :: SPIRV.ExecutionModel ) + ( stageInfo :: SPIRV.ExecutionInfo Nat stage ) + ( j_bds :: BindingsMap ) + ( j_iface :: TLInterface ) + ( i :: ProgramState ) + . + ( GHC.Stack.HasCallStack + , KnownSymbol name + , Known SPIRV.ExecutionModel stage + , Known (SPIRV.ExecutionInfo Nat stage) stageInfo + , ValidEntryPoint name stageInfo i j_bds + , stageInfo ~ GetExecutionInfo name stage i + ) + => Program + ( EntryPointStartState name stageInfo i ) + ( EntryPointEndState name stageInfo j_bds j_iface i ) + ( Code () ) + -> Program + i + ( SetInterface name stageInfo j_iface i ) + ( Code () ) +entryPoint ep = fromAST ( DefEntryPoint (Proxy @name) (Proxy @stageInfo) :$ toAST ep ) + +-- | Define a new shader stage. +-- +-- This function provides a convenience wrapper around 'entryPoint', +-- suitable for creating a program containing a single shader and +-- no top-level functions. +-- +-- Type-level arguments: +-- +-- *@name@: name of entry point, +-- *@shader@: which shader stage to use, +-- *@defs@: top-level inputs/outputs of shader stage. +-- +-- Other type-level arguments should be inferred. +shader :: forall + ( name :: Symbol ) + ( shader :: SPIRV.Shader ) + ( defs :: [Symbol :-> Definition] ) + ( stage :: SPIRV.ExecutionModel ) + ( stageInfo :: SPIRV.ExecutionInfo Nat stage ) + ( j_bds :: BindingsMap ) + ( j_iface :: TLInterface ) + ( cfg :: CFGState ) + ( funs :: [Symbol :-> FunctionInfo ] ) + ( eps :: [Symbol :-> EntryPointInfo ] ) + ( g_iface :: TLInterface ) + ( rayQs :: Map Symbol RayQueryState ) + ( bkend :: SPIRV.Backend ) + ( i :: ProgramState ) + . ( GHC.Stack.HasCallStack + , KnownDefinitions defs + , ValidDefinitions defs + , GetExecutionInfo name stage i ~ stageInfo + , funs ~ '[ ] + , i ~ 'ProgramState (StartBindings defs) 'TopLevel cfg funs eps g_iface rayQs bkend + , i ~ StartState defs + , KnownSymbol name + , stage ~ 'SPIRV.Stage ('SPIRV.ShaderStage shader) + , Known SPIRV.Shader shader + , Known (SPIRV.ExecutionInfo Nat stage) stageInfo + , EndBindings defs ~ StartBindings defs + , ValidEntryPoint name stageInfo ('ProgramState (EndBindings defs) 'TopLevel cfg funs eps g_iface rayQs bkend) j_bds + ) + => Program + ( EntryPointStartState name stageInfo i ) + ( EntryPointEndState name stageInfo j_bds j_iface i ) + ( Code () ) + -> ShaderModule name shader defs (SetInterface name stageInfo j_iface i) +shader + = ShaderModule + . entryPoint @name @stage + +-- Optics. + +-- | /Use/ an optic, returning a monadic value read from the (indexed) state. +-- +-- Like @use@ from the lens library, except the optic needs to be passed with a type application. +use :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic + , Syntactic (ProgUser optic) + , Internal (ProgUser optic) ~ AugUser optic + ) + => ProgUser optic +use = fromAST ( Use sLength ( opticSing @optic ) ) + +-- | Assign a new value with an optic. +-- +-- Like @assign@ from the lens library, except the optic needs to be passed with a type application. +assign :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Settable optic + , Syntactic (ProgAssigner optic) + , Internal (ProgAssigner optic) ~ AugAssigner optic + ) + => ProgAssigner optic +assign = fromAST ( Assign sLength ( opticSing @optic ) ) + +-- *** Get, put, modify. + +-- | Get the value of a variable. +-- Like @get@ for state monads, except a binding name needs to be specified with a type application. +-- +-- Synonym for @use \@(Name k)@. +get :: forall (k :: Symbol) (a :: Type) (i :: ProgramState). + ( KnownSymbol k + , Gettable (Name k :: Optic '[] i a) + , a ~ Has k i + , PrimTy a + ) + => Program i i (Code a) +get = use @(Name k :: Optic '[] i a) + +-- | Set the value of a variable. +-- Like @put@ for state monads, except a binding name needs to be specified with a type application. +-- +-- Synonym for @assign \@(Name k)@. +put :: forall (k :: Symbol) (a :: Type) (i :: ProgramState). + ( KnownSymbol k + , Settable (Name k :: Optic '[] i a) + , a ~ Has k i + , PrimTy a + ) + => Code a -> Program i i (Code ()) +put = assign @(Name k :: Optic '[] i a) + +-- | Modify the value of a variable. +-- | Like @modify@ for state monads, except a binding name needs to be specified with a type application. +-- +-- Synonym for @modifying \@(Name k)@. +modify :: forall (k :: Symbol) (a :: Type) (i :: ProgramState). + ( KnownSymbol k + , Gettable (Name k :: Optic '[] i a) + , Settable (Name k :: Optic '[] i a) + , a ~ Has k i + , PrimTy a + ) + => (Code a -> Code a) -> Program i i (Code ()) +modify = modifying @(Name k :: Optic '[] i a) + +-------------------------------------------------------------------------- +-- Image operations (synonyms for 'use'/'assign'). + +-- | Read from an image (with or without a sampler). +-- +-- Synonym for @use \@(ImageTexel \"imgName\")@, +-- but with no additional image operands provided. +-- +-- Type-level arguments: +-- +-- * @imgName@: image name, +-- * @props@: image properties (usually inferred), +-- * @i@: monadic state (usually inferred). +imageRead :: forall + ( imgName :: Symbol ) + ( props :: ImageProperties ) + ( imgCds :: Type ) + ( imgTexel :: Type ) + ( i :: ProgramState ) + . + ( KnownSymbol imgName + , PrimTy imgCds + , PrimTy imgTexel + , imgTexel ~ ImageTexelType props '[] + , Gettable + ( ImageTexel imgName + :: Optic + '[ ImageOperands props '[], imgCds ] + i + ( ImageTexelType props '[] ) -- can't use "imgTexel", GHC trac #15710 + ) + , props ~ LookupImageProperties imgName i + , Known ImageProperties props + , ValidImageRead props '[] imgCds + ) + => Code imgCds + -> Program i i (Code (ImageTexelType props '[])) +imageRead = use + @( ImageTexel imgName + :: Optic + '[ ImageOperands props '[], imgCds ] + i + imgTexel + ) + NilOps + +-- | Write directly to an image (without a sampler). +-- +-- Synonym for @assign \@(ImageTexel \"imgName\")@, +-- but with no additional image operands provided. +-- +-- Type-level arguments: +-- +-- * @imgName@: image name, +-- * @props@: image properties (usually inferred), +-- * @i@: monadic state (usually inferred). +imageWrite :: forall + ( imgName :: Symbol ) + ( props :: ImageProperties ) + ( imgCds :: Type ) + ( imgTexel :: Type ) + ( i :: ProgramState ) + . + ( KnownSymbol imgName + , PrimTy imgCds + , PrimTy imgTexel + , imgTexel ~ ImageTexelType props '[] + , Gettable + ( ImageTexel imgName + :: Optic + '[ ImageOperands props '[], imgCds ] + i + ( ImageTexelType props '[] ) -- can't use "imgTexel", GHC trac #15710 + ) + , props ~ LookupImageProperties imgName i + , Known ImageProperties props + , ValidImageWrite props '[] imgCds + ) + => Code imgCds + -> Code imgTexel + -> Program i i ( Code () ) +imageWrite = assign + @( ImageTexel imgName + :: Optic + '[ ImageOperands props '[], imgCds ] + i + imgTexel + ) + NilOps + +-- *** Atomic operations. + +-- $atomics +-- Atomic operations on storage buffers and workgroup variables, through an +-- optic passed with a type application. The optic must focus on a scalar, e.g. +-- a member or an array element of the buffer. The run-time indices of the +-- optic come first, then the operands of the operation: +-- +-- > previous <- atomicAdd @( Name "buf" :.: Name "arr" :.: AnIndex Word32 ) i v +-- +-- Except for 'atomicStore', an atomic operation returns the previous value. +-- All operations are atomic at 'SPIRV.Synchronisation.Device' scope with +-- relaxed memory semantics (no ordering constraints on other memory accesses). + +-- | Atomically read the value. +atomicLoad :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicTy (Part optic) + , Syntactic (ProgUser optic) + , Internal (ProgUser optic) ~ AugUser optic + ) + => ProgUser optic +atomicLoad = fromAST ( Atomic SAtomicLoad sLength ( opticSing @optic ) ) + +-- | Atomically write a value. +atomicStore :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicTy (Part optic) + , Syntactic (ProgAssigner optic) + , Internal (ProgAssigner optic) ~ AugAssigner optic + ) + => ProgAssigner optic +atomicStore = fromAST ( Atomic SAtomicStore sLength ( opticSing @optic ) ) + +-- | Atomically write a value, returning the previous value. +atomicExchange :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicTy (Part optic) + , Syntactic (ProgExchanger optic) + , Internal (ProgExchanger optic) ~ AugExchanger optic + ) + => ProgExchanger optic +atomicExchange = fromAST ( Atomic SAtomicExchange sLength ( opticSing @optic ) ) + +-- | Atomically write a new value if the current value equals an expected +-- value, returning the previous value. Takes the expected value, then the +-- new value. +atomicCompareExchange :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicIntegralTy (Part optic) + , Syntactic (ProgCompareExchanger optic) + , Internal (ProgCompareExchanger optic) ~ AugCompareExchanger optic + ) + => ProgCompareExchanger optic +atomicCompareExchange = + fromAST ( Atomic SAtomicCompareExchange sLength ( opticSing @optic ) ) + +-- | Atomically add one, returning the previous value. +atomicIncrement :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicIntegralTy (Part optic) + , Syntactic (ProgUser optic) + , Internal (ProgUser optic) ~ AugUser optic + ) + => ProgUser optic +atomicIncrement = + fromAST ( Atomic SAtomicIncrement sLength ( opticSing @optic ) ) + +-- | Atomically subtract one, returning the previous value. +atomicDecrement :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicIntegralTy (Part optic) + , Syntactic (ProgUser optic) + , Internal (ProgUser optic) ~ AugUser optic + ) + => ProgUser optic +atomicDecrement = + fromAST ( Atomic SAtomicDecrement sLength ( opticSing @optic ) ) + +-- | Atomically add a value, returning the previous value. +atomicAdd :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicTy (Part optic) + , Syntactic (ProgExchanger optic) + , Internal (ProgExchanger optic) ~ AugExchanger optic + ) + => ProgExchanger optic +atomicAdd = fromAST ( Atomic SAtomicAdd sLength ( opticSing @optic ) ) + +-- | Atomically subtract a value, returning the previous value. +atomicSub :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicIntegralTy (Part optic) + , Syntactic (ProgExchanger optic) + , Internal (ProgExchanger optic) ~ AugExchanger optic + ) + => ProgExchanger optic +atomicSub = fromAST ( Atomic SAtomicSub sLength ( opticSing @optic ) ) + +-- | Atomically replace the value by the minimum of it and a given value, +-- returning the previous value. +atomicMin :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicTy (Part optic) + , Syntactic (ProgExchanger optic) + , Internal (ProgExchanger optic) ~ AugExchanger optic + ) + => ProgExchanger optic +atomicMin = fromAST ( Atomic SAtomicMin sLength ( opticSing @optic ) ) + +-- | Atomically replace the value by the maximum of it and a given value, +-- returning the previous value. +atomicMax :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicTy (Part optic) + , Syntactic (ProgExchanger optic) + , Internal (ProgExchanger optic) ~ AugExchanger optic + ) + => ProgExchanger optic +atomicMax = fromAST ( Atomic SAtomicMax sLength ( opticSing @optic ) ) + +-- | Atomically replace the value by its bitwise and with a given value, +-- returning the previous value. +atomicAnd :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicIntegralTy (Part optic) + , Syntactic (ProgExchanger optic) + , Internal (ProgExchanger optic) ~ AugExchanger optic + ) + => ProgExchanger optic +atomicAnd = fromAST ( Atomic SAtomicAnd sLength ( opticSing @optic ) ) + +-- | Atomically replace the value by its bitwise or with a given value, +-- returning the previous value. +atomicOr :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicIntegralTy (Part optic) + , Syntactic (ProgExchanger optic) + , Internal (ProgExchanger optic) ~ AugExchanger optic + ) + => ProgExchanger optic +atomicOr = fromAST ( Atomic SAtomicOr sLength ( opticSing @optic ) ) + +-- | Atomically replace the value by its bitwise exclusive or with a given +-- value, returning the previous value. +atomicXor :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic, StatefulOptic optic + , Gettable optic, Settable optic + , AtomicIntegralTy (Part optic) + , Syntactic (ProgExchanger optic) + , Internal (ProgExchanger optic) ~ AugExchanger optic + ) + => ProgExchanger optic +atomicXor = fromAST ( Atomic SAtomicXor sLength ( opticSing @optic ) ) + +-------------------------------------------------------------------------- + +-- | Query the length of a run-time array. +-- +-- Usage: +-- +-- > arrayLength @( Name "structName" :.: Name "arrayName" ) +-- +-- This returns the size of the run-time array, bound within the structure named @"structureName"@ +-- with member field name @"arrayName"@. +-- +-- Note that run-time arrays can only appear as the last structure member. +arrayLength + :: forall optic i + . ( i ~ Whole optic ) + => ArrayLength (Whole optic) optic + => Program i i (Code Word32) +arrayLength = arrayLength' @_ @_ @i @optic + +class ArrayLength (i :: ProgramState) (optic :: Optic is i r) where + arrayLength' :: Program i i ( Code Word32 ) + +instance + ( empty1 ~ '[], empty2 ~ '[], r ~ RuntimeArray a + , KnownSymbol structName, KnownNat memberIndex + , struct ~ Has structName i + , struct ~ Struct as + ) + => ArrayLength i + ( ( Field_ ( structName :: Symbol ) :: Optic empty1 i struct ) + `ComposeO` ( Field_ ( memberIndex :: Nat ) :: Optic empty2 struct r ) + ) + where + arrayLength' = fromAST $ ArrayLength ( Proxy :: Proxy structName ) ( Proxy :: Proxy memberIndex ) + +instance + ( empty1 ~ '[], empty2 ~ '[], r ~ RuntimeArray a + , KnownSymbol structName, KnownNat memberIndex + , struct ~ Has structName i + , ( memberIndex ':-> r ) ~ StructIndexFromName memberName as + , struct ~ Struct as + ) + => ArrayLength i + ( ( Field_ ( structName :: Symbol ) :: Optic empty1 i struct ) + `ComposeO` ( Field_ ( memberName :: Symbol ) :: Optic empty2 struct r ) + ) + where + arrayLength' = fromAST $ ArrayLength ( Proxy :: Proxy structName ) ( Proxy :: Proxy memberIndex ) + +-------------------------------------------------------------------------- +-- subgroup operations + +-- Unsightly hack to convert a group operation to a `SPIR-V` word value. +groupOperationToWord32 :: SPIRV.GroupOperation -> Code Word32 +groupOperationToWord32 op = MkID ( ID (SPIRV.groupOperationToWord32 op), primTy @Word32 ) + +class (Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp) + => HasGroupAdd scope groupOp a ( i :: ProgramState ) where + groupAdd :: Code a -> Program i i ( Code a ) + +class (Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp) + => HasGroupMul scope groupOp a ( i :: ProgramState ) where + groupMul :: Code a -> Program i i ( Code a ) + +class (Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp) + => HasGroupMinMax scope groupOp a ( i :: ProgramState ) where + groupMin :: Code a -> Program i i ( Code a ) + groupMax :: Code a -> Program i i ( Code a ) + +class (Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp) + => HasGroupBitwise scope groupOp a ( i :: ProgramState ) where + groupBitwiseAnd :: Code a -> Program i i ( Code a ) + groupBitwiseOr :: Code a -> Program i i ( Code a ) + groupBitwiseXor :: Code a -> Program i i ( Code a ) + +class (Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp) + => HasGroupLogic scope groupOp a ( i :: ProgramState ) where + groupLogicalAnd :: Code a -> Program i i ( Code a ) + groupLogicalOr :: Code a -> Program i i ( Code a ) + groupLogicalXor :: Code a -> Program i i ( Code a ) + +instance ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp + , ScalarTy a, AdditiveMonoid a + ) + => HasGroupAdd scope groupOp a i where + groupAdd = primOp @'(i, a) @SPIRV.GroupAdd + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + +instance ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp + , ScalarTy a, Semiring a + ) + => HasGroupMul scope groupOp a i where + groupMul = primOp @'(i, a) @SPIRV.GroupMul + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + +instance ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp + , ScalarTy a, Ord a + ) + => HasGroupMinMax scope groupOp a i where + groupMin = primOp @'(i, a) @SPIRV.GroupMin + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + groupMax = primOp @'(i, a) @SPIRV.GroupMax + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + +instance ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp + , ScalarTy a, Bits a + ) + => HasGroupBitwise scope groupOp a i where + groupBitwiseAnd = primOp @'(i,a) @SPIRV.GroupBitwiseAnd + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + groupBitwiseOr = primOp @'(i,a) @SPIRV.GroupBitwiseOr + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + groupBitwiseXor = primOp @'(i,a) @SPIRV.GroupBitwiseXor + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + +instance ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp + , b ~ Bool + ) + => HasGroupLogic scope groupOp b i where + groupLogicalAnd = primOp @i @SPIRV.GroupLogicalAnd + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + groupLogicalOr = primOp @i @SPIRV.GroupLogicalOr + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + groupLogicalXor = primOp @i @SPIRV.GroupLogicalXor + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + +instance {-# OVERLAPPING #-} + ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp + , ScalarTy a, AdditiveMonoid a + , KnownNat n + ) + => HasGroupAdd scope groupOp ( V n a ) i where + groupAdd = primOp @'(i, V n a) @('Vectorise SPIRV.GroupAdd) + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + +instance {-# OVERLAPPING #-} + ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp + , ScalarTy a, Semiring a + , KnownNat n + ) + => HasGroupMul scope groupOp ( V n a ) i where + groupMul = primOp @'(i, V n a) @('Vectorise SPIRV.GroupMul) + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + +instance {-# OVERLAPPING #-} + ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp + , ScalarTy a, Ord a + , KnownNat n + ) + => HasGroupMinMax scope groupOp ( V n a ) i where + groupMin = primOp @'(i, V n a) @('Vectorise SPIRV.GroupMin) + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + groupMax = primOp @'(i, V n a) @('Vectorise SPIRV.GroupMax) + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + +instance {-# OVERLAPPING #-} + ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp + , ScalarTy a, Bits a + , KnownNat n + ) + => HasGroupBitwise scope groupOp ( V n a ) i where + groupBitwiseAnd = primOp @'(i, V n a) @('Vectorise SPIRV.GroupBitwiseAnd) + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + groupBitwiseOr = primOp @'(i, V n a) @('Vectorise SPIRV.GroupBitwiseOr) + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + groupBitwiseXor = primOp @'(i, V n a) @('Vectorise SPIRV.GroupBitwiseXor) + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + +instance {-# OVERLAPPING #-} + ( Known SPIRV.SynchronisationScope scope, Known SPIRV.GroupOperation groupOp + , KnownNat n, b ~ Bool + ) + => HasGroupLogic scope groupOp (V n b) i where + groupLogicalAnd = primOp @'(i,n) @('Vectorise SPIRV.GroupLogicalAnd) + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + groupLogicalOr = primOp @'(i,n) @('Vectorise SPIRV.GroupLogicalOr) + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + groupLogicalXor = primOp @'(i,n) @('Vectorise SPIRV.GroupLogicalXor) + (Lit . SPIRV.synchronisationScope $ knownValue @scope :: Code Word32) + (groupOperationToWord32 $ knownValue @groupOp) + +-------------------------------------------------------------------------- +-- geometry shader primitive instructions + +-- | Geometry shader: write the current output values at the current vertex index. +emitVertex :: forall (i :: ProgramState) + . ( ExecutionContext i ~ Just SPIRV.Geometry ) + => Program i i ( Code () ) +emitVertex = primOp @i @SPIRV.EmitGeometryVertex + +-- | Geometry shader: end the current primitive and pass to the next one. +endPrimitive :: forall (i :: ProgramState) + . ( ExecutionContext i ~ Just SPIRV.Geometry ) + => Program i i ( Code () ) +endPrimitive = primOp @i @SPIRV.EndGeometryPrimitive + +-------------------------------------------------------------------------- +-- memory synchronisation primitive instructions + +-- | Control barrier: wait for other invocations to reach the current point of execution. +-- +-- Can also act as a memory barrier if a memory synchronisation scope is specified. +controlBarrier :: forall (i :: ProgramState) + . SPIRV.SynchronisationScope + -> Maybe ( SPIRV.SynchronisationScope, SPIRV.MemorySemantics ) + -> Program i i ( Code () ) +controlBarrier controlScope memScope + = primOp @i @SPIRV.ControlSync + ( Lit $ controlScopeWord32 :: Code Word32 ) + ( Lit $ fromMaybe controlScopeWord32 $ SPIRV.synchronisationScope . fst <$> memScope :: Code Word32 ) + -- ^^^^^^^^^^^^^^^^^^ + -- can get validation errors if this is set to 0 (which is "CrossDevice" scope) + -- even though this field is supposed to be ignored if the memory semantics argument is 0 + ( Lit $ fromMaybe 0 $ SPIRV.memorySemanticsBitmask . snd <$> memScope :: Code Word32 ) + where + controlScopeWord32 :: Word32 + controlScopeWord32 = SPIRV.synchronisationScope controlScope + +-- | Memory barrier: ensure ordering on memory accesses. +memoryBarrier :: forall (i :: ProgramState) + . SPIRV.SynchronisationScope + -> SPIRV.MemorySemantics + -> Program i i ( Code () ) +memoryBarrier memScope memSem + = primOp @i @SPIRV.MemorySync + ( Lit $ SPIRV.synchronisationScope memScope :: Code Word32 ) + ( Lit $ SPIRV.memorySemanticsBitmask memSem :: Code Word32 ) + +-------------------------------------------------------------------------- +-- type synonyms for use/assign + +type family ProgListVariadic + ( is :: [Type] ) + ( s :: ProgramState ) + ( a :: Type ) + = ( r :: Type ) + | r -> is s a where + ProgListVariadic '[] s a = Program s s (Code a) + ProgListVariadic ( i ': is ) s a = Code i -> ProgListVariadic is s a + + +-- recall (defined in FIR.Syntax.Optics): +-- type User (g :: Optic is s a) = ListVariadicIx is s a +-- type Assigner (g :: Optic is s a) = ListVariadicIx (is `Postpend` s) s () + +type ProgUser (optic :: Optic is s a) = ProgListVariadic is s a +type ProgAssigner (optic :: Optic is s a) = ProgListVariadic (is `Postpend` a) s () +type ProgExchanger (optic :: Optic is s a) + = ProgListVariadic (is `Postpend` a) s a +type ProgCompareExchanger (optic :: Optic is s a) + = ProgListVariadic (is `Postpend` a `Postpend` a) s a + +-------------------------------------------------------------------------- +-- modifying + +type family ProgVariadicModifier + ( is :: [Type] ) + ( s :: ProgramState ) + ( a :: Type ) + = ( r :: Type ) + | r -> is s a + where + ProgVariadicModifier '[] s a = (Code a -> Code a) -> Program s s (Code ()) + ProgVariadicModifier (i ': is) s a = Code i -> ProgVariadicModifier is s a + +type ProgModifier (optic :: Optic is s a) = ProgVariadicModifier is s a + +-- | Modify a value with an optic. +-- +-- Like @modifying@ from the lens library, except the optic needs to be passed with a type application. +modifying + :: forall optic. + ( GHC.Stack.HasCallStack + , KnownOptic optic + , StatefulOptic optic + , Settable optic + , Gettable optic + , Syntactic (ProgUser optic) + , Internal (ProgUser optic) ~ AugUser optic + , Syntactic (ProgAssigner optic) + , Internal (ProgAssigner optic) ~ AugAssigner optic + , Modifier (Indices optic) (Whole optic) (Part optic) + ) + => ProgModifier optic +modifying + = modifier @(Indices optic) @(Whole optic) @(Part optic) + ( use @optic ) + ( assign @optic ) + +class Modifier is s a where + modifier :: ProgListVariadic is s a + -> ProgListVariadic (is `Postpend` a) s () + -> ProgVariadicModifier is s a + +instance Modifier '[] s a where + modifier used assigned f + = ixFmap f used Indexed.>>= assigned + +instance Modifier is s a => Modifier (i ': is) s a where + modifier used assigned i + = modifier @is @s @a (used i) (assigned i) + +-------------------------------------------------------------------------- +-- Instances for codensity representation + +-- Logical operations + +-- $logical +-- Instances for: +-- +-- 'Boolean', +-- +-- 'Eq', 'Ord' (note: not the "Prelude" type classes). +instance Boolean b => Boolean (Program i i b) where + true = ixPure true + false = ixPure false + (&&) = ixLiftA2 (&&) + (||) = ixLiftA2 (||) + not = ixFmap not + +instance ( PrimTy a, Eq a, Logic a ~ Bool + , i ~ j + , r ~ Code a + ) + => Eq (Program i j r) where + type Logic (Program i j r) = Program i i (Code Bool) + (==) = ixLiftA2 (==) + (/=) = ixLiftA2 (/=) + +instance ( ScalarTy a, Ord a, Logic a ~ Bool + , i ~ j + , r ~ Code a + ) + => Ord (Program i j r) where + (<=) = ixLiftA2 (<=) + (>=) = ixLiftA2 (>=) + (<) = ixLiftA2 (<) + (>) = ixLiftA2 (>) + min = ixLiftA2 min + max = ixLiftA2 max + +-- * Bitwise operations +-- +-- $bitwise +-- Instances for: +-- +-- 'Bits', 'BitShift' (note: not 'Data.Bits.Bits'). + +instance ( ScalarTy a + , r ~ Code a + , j ~ i + , Bits a + ) => Bits (Program i j r) where + (.&.) = ixLiftA2 (.&.) + (.|.) = ixLiftA2 (.|.) + xor = ixLiftA2 xor + complement = ixFmap complement + zeroBits = ixPure zeroBits + bitReverse = ixFmap bitReverse + +instance ( ScalarTy a, ScalarTy s + , BitShift '(a,s) + , x ~ Code a + , t ~ Code s + , j ~ i, i' ~ i, j' ~ i + ) + => BitShift '(Program i j x, Program i' j' t) where + shiftL = ixLiftA2 shiftL + shiftR = ixLiftA2 shiftR + +instance ( ScalarTy a, ScalarTy s + , BitShift '(a,s) + , x ~ Code a + , i ~ j + ) + => BitShift '(Program i j x, Code s) where + shiftL a s = shiftL @'(Program i j x, Program i i (Code s)) a (ixPure s) + shiftR a s = shiftR @'(Program i j x, Program i i (Code s)) a (ixPure s) + +instance (ScalarTy a, ScalarTy b, BitCast a b, i1 ~ j1, i2 ~ j2, i1 ~ i2, x ~ Code a, y ~ Code b) + => BitCast (Program i1 j1 x) (Program i2 j2 y) where + bitcast = ixFmap bitcast + +-- Numeric operations + +-- $numeric +-- Instances for: +-- +-- 'AdditiveMonoid', 'AdditiveGroup', 'Signed', +-- +-- 'Semiring', 'Ring', +-- +-- 'DivisionRing', 'Archimedean' (Archimedean ordered group), +-- +-- 'Floating', 'RealFloat' (note: not the "Prelude" type classes). +instance (ScalarTy a, AdditiveMonoid a, j ~ i) => AdditiveMonoid (Program i j (Code a)) where + (+) = ixLiftA2 (+) + zero = ixPure zero + fromInteger = ixPure . fromInteger +instance (ScalarTy a, Semiring a, j ~ i) => Semiring (Program i j (Code a)) where + (*) = ixLiftA2 (*) +instance (ScalarTy a, CancellativeAdditiveMonoid a, j ~ i) => CancellativeAdditiveMonoid (Program i j (Code a)) where + (-) = ixLiftA2 (-) +instance (ScalarTy a, AdditiveGroup a, j ~ i) => AdditiveGroup (Program i j (Code a)) where + negate = ixFmap negate +instance (ScalarTy a, Signed a, j ~ i) => Signed (Program i j (Code a)) where + abs = ixFmap abs + signum = ixFmap signum +instance (ScalarTy a, DivisionRing a, j ~ i) => DivisionRing (Program i j (Code a)) where + (/) = ixLiftA2 (/) + fromRational = ixPure . fromRational +instance ( ScalarTy a + , Archimedean a + , Archimedean (Code a) + , Logic a ~ Bool + , j ~ i + ) => Archimedean (Program i j (Code a)) where + mod = ixLiftA2 mod + rem = ixLiftA2 rem + div = ixLiftA2 div + +instance (ScalarTy a, Floating a, j ~ i) => Floating (Program i j (Code a)) where + pi = ixPure pi + exp = ixFmap exp + log = ixFmap log + sqrt = ixFmap sqrt + invSqrt = ixFmap invSqrt + sin = ixFmap sin + cos = ixFmap cos + tan = ixFmap tan + asin = ixFmap asin + acos = ixFmap acos + atan = ixFmap atan + sinh = ixFmap sinh + cosh = ixFmap cosh + tanh = ixFmap tanh + asinh = ixFmap asinh + acosh = ixFmap acosh + atanh = ixFmap atanh + (**) = ixLiftA2 (**) + +instance (ScalarTy a, RealFloat a, Eq a, Logic a ~ Bool, j ~ i) => RealFloat (Program i j (Code a)) where + atan2 = ixLiftA2 atan2 + isNaN = ixFmap isNaN + isInfinite = ixFmap isInfinite + +-- Numeric conversions + +-- $conversions +-- Instance for 'Convert', 'Rounding'. +instance ( ScalarTy a, ScalarTy b + , Convert '(Code a, Code b) + , j ~ i, k ~ i, l ~ i + ) + => Convert '( Program i j (Code a) + , Program k l (Code b) + ) where + convert = ixFmap ( convert @'(Code a, Code b) ) + +instance ( ScalarTy a, ScalarTy b, Rounding '(Code a, Code b) + , j ~ i, k ~ i, l ~ i + ) + => Rounding '( Program i j (Code a) + , Program k l (Code b) + ) where + truncate = ixFmap truncate + round = ixFmap round + floor = ixFmap floor + ceiling = ixFmap ceiling + +-- Vectors + +-- $vectors +-- Instances for: +-- +-- 'Semimodule', 'LinearModule', 'Inner', 'Cross'. +instance (ScalarTy a, Semiring a, j ~ i) => Semimodule Nat (Program i j (Code (V 0 a))) where + type Scalar (Program i j (Code (V 0 a))) = Program i j (Code a) + type OfDim (Program i j (Code (V 0 a))) Nat n = Program i j (Code (V n a)) + type ValidDim (Program i j (Code (V 0 a))) Nat n = KnownNat n + + (^+^) = ixLiftA2 (^+^) + (^*) = ixLiftA2 (^*) + +instance (ScalarTy a, Ring a, j ~ i) => LinearModule Nat (Program i j (Code (V 0 a))) where + (^-^) = ixLiftA2 (^-^) + +instance (ScalarTy a, Floating a, j ~ i) => Inner Nat (Program i j (Code (V 0 a))) where + (^.^) = ixLiftA2 (^.^) + normalise = ixFmap normalise + +instance (ScalarTy a, Floating a, j ~ i) => Cross Nat (Program i j (Code (V 0 a))) where + type CrossDim (Program i j (Code (V 0 a))) Nat n = ( n ~ 3 ) + cross = ixLiftA2 cross + +-- Matrices + +-- $matrices +-- Instance for 'Matrix'. + +type instance VectorOf (Program i j (Code (M 0 0 a))) = Program i j (Code (V 0 a)) + +instance (ScalarTy a, Floating a, j ~ i) => Matrix Nat (Program i j (Code (M 0 0 a))) where + type OfDims (Program i j (Code (M 0 0 a))) Nat '(m,n) = Program i j (Code (M m n a)) + + diag = ixFmap diag + konst = ixFmap konst + + transpose = ixFmap transpose + inverse = ixFmap inverse + determinant = ixFmap determinant + + (!+!) = ixLiftA2 (!+!) + (!-!) = ixLiftA2 (!-!) + (!*!) = ixLiftA2 (!*!) + (^*!) = ixLiftA2 (^*!) + (!*^) = ixLiftA2 (!*^) + (!*) = ixLiftA2 (!*) + + +instance TypeError ( Text "Failable pattern detected in 'do' block, but only unfailable patterns are supported." + :$$: Text "" + :$$: Text "As inference of pattern failability is sometimes patchy," + :$$: Text "consider using an irrefutable pattern instead, such as:" + :$$: Text "" + :$$: Text " ~(Vec4 x y z w) <- get @\"position\"" + :$$: Text "" + :$$: Text "instead of" + :$$: Text "" + :$$: Text " Vec4 x y z w <- get @\"position\"" + :$$: Text "" + ) => MonadIxFail (Codensity AST) where + fail = error "'fail': irrefutable pattern failed to match." diff --git a/src/FIR/Syntax/RayTracing.hs b/src/FIR/Syntax/RayTracing.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/RayTracing.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: FIR.Syntax.RayTracing + +Ray-tracing and ray-query operations, such as 'traceRay', 'reportIntersection', 'executeCallable'... +-} + +module FIR.Syntax.RayTracing where + +-- base +import Data.Kind + ( Type ) +import Data.Proxy + ( Proxy(..) ) +import Data.Word + ( Word32, Word64 ) +import GHC.TypeLits + ( Symbol ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- fir +import Data.Type.Known + ( Known, knownValue ) +import Data.Type.Map + ( Lookup ) +import FIR.AST +import FIR.AST.Type + ( AugType(..), Eff ) +import FIR.Module + ( Program ) +import FIR.Prim.RayTracing + ( AccelerationStructure + , RayQuery(..), RayQueryProceedState(..) + , RayQueryCandidateIntersection(..), RayQueryCommittedIntersection(..) + , IntersectionType(..) + ) +import FIR.Prim.Types + ( PrimTy ) +import FIR.ProgramState + ( ProgramState, ExecutionContext, RayQueries ) +import FIR.Syntax.Program + ( ) -- Syntactic instance for 'Program' +import FIR.Validation.RayTracing + ( CanTraceRay, CanExecuteCallable + , NewRayQuery, RayQueryProceed, RayQueryCandidateState, RayQueryCommittedState + , Terminate, CanGenerateIntersection, CanConfirmIntersection + , HasRayQuery, CanGetIntersectionT, HasSomeIntersection, HasSomeTriangleIntersection + ) +import Math.Linear + ( V, M ) +import qualified SPIRV.Operation as SPIRV.Op +import qualified SPIRV.PrimOp as SPIRV + ( RayPrimOp(..) ) +import qualified SPIRV.Stage as SPIRV + ( AnyHit, Intersection ) + +-------------------------------------------------------------------------- +-- ray tracing instructions + +data RayInfo + = RayInfo + { rayFlags :: Code Word32 + , rayOrigin :: Code ( V 3 Float ) + , rayDirection :: Code ( V 3 Float ) + , rayTMin :: Code Float + , rayTMax :: Code Float + , cullMask :: Code Word32 -- ^ Only the least significant 8 bits are used. + } + +data RayShaderInfo + = RayShaderInfo + { bindingTableOffset :: Code Word32 -- ^ Only the least significant 4 bits are used. + , bindingTableStride :: Code Word32 -- ^ Only the least significant 4 bits are used. + , missShaderIndex :: Code Word32 -- ^ Only the least significant 16 bits are used. + } + +traceRay + :: forall + ( rayPayloadName :: Symbol ) + ( i :: ProgramState ) + . ( Known Symbol rayPayloadName + , CanTraceRay rayPayloadName i + ) + => Code AccelerationStructure + -> RayInfo + -> RayShaderInfo + -> Program i i ( Code () ) +traceRay accelerationStructure ( RayInfo { .. } ) ( RayShaderInfo { .. } ) = fromAST $ + TraceRay + { traceRayAccelerationStructure = accelerationStructure + , traceRayRayFlags = rayFlags + , traceRayCullMask = cullMask + , traceRaySBTOffset = bindingTableOffset + , traceRaySBTStride = bindingTableStride + , traceRayMissIndex = missShaderIndex + , traceRayRayOrigin = rayOrigin + , traceRayRayTMin = rayTMin + , traceRayRayDirection = rayDirection + , traceRayRayTMax = rayTMax + , traceRayPayloadID = knownValue @rayPayloadName + } + +reportIntersection + :: forall (i :: ProgramState) + . ( ExecutionContext i ~ Just SPIRV.Intersection ) + => Code Float -- ^ HitT + -> Code Word32 -- ^ Hit kind. + -> Program i i ( Code Bool ) +reportIntersection = primOp @i @SPIRV.RT_ReportIntersection + +ignoreIntersection + :: forall (i :: ProgramState) + . ( ExecutionContext i ~ Just SPIRV.AnyHit ) + => Program i i ( Code () ) +ignoreIntersection = primOp @i @SPIRV.RT_IgnoreIntersection + +terminateRay + :: forall (i :: ProgramState) + . ( ExecutionContext i ~ Just SPIRV.AnyHit ) + => Program i i ( Code () ) +terminateRay = primOp @i @SPIRV.RT_TerminateRay + +executeCallable + :: forall + ( callableDataName :: Symbol ) + ( i :: ProgramState ) + . ( Known Symbol callableDataName + , CanExecuteCallable callableDataName i + ) + => Code Word32 -- ^ Index into the shader binding table. + -> Program i i ( Code () ) +executeCallable bindingTableOffset = fromAST $ + ExecuteCallable bindingTableOffset ( knownValue @callableDataName ) + +accelerationStructureFromDeviceAddress :: Code Word64 -> Code AccelerationStructure +accelerationStructureFromDeviceAddress + = primOp @'() @'SPIRV.RT_AccelerationStructureFromDeviceAddress + +-------------------------------------------------------------------------- +-- ray query instructions + +initialize + :: forall + ( rayQuery :: Symbol ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery ) + => Code AccelerationStructure + -> RayInfo + -> Program i ( NewRayQuery rayQuery i ) ( Code () ) +initialize accelStructure ( RayInfo {..} ) = fromAST $ + RayQueryInitialize + { rayQueryRayQueryName = RayQuery (knownValue @rayQuery) + , rayQueryAccelerationStructure = accelStructure + , rayQueryRayFlags = rayFlags + , rayQueryCullMask = cullMask + , rayQueryRayOrigin = rayOrigin + , rayQueryRayTMin = rayTMin + , rayQueryRayDirection = rayDirection + , rayQueryRayTMax = rayTMax + } + +ifProceeding + :: forall + ( rayQuery :: Symbol ) + ( a :: Type ) + ( i :: ProgramState ) + ( j1 :: ProgramState ) + ( j2 :: ProgramState ) + . ( Known Symbol rayQuery, PrimTy a ) + => Program ( RayQueryProceed rayQuery ( Incomplete Nothing ) i ) j1 ( Code a ) + -> Program ( RayQueryProceed rayQuery Complete i ) j2 ( Code a ) + -> Program i i ( Code a ) +ifProceeding proceed don't = + fromAST + ( IfM :$ ( RayQueryPrimOp (Proxy @Bool) SPIRV.Op.RayQueryProceed ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i Bool ) ) + :$ ( unsafeCoerce $ toAST proceed ) + :$ ( unsafeCoerce $ toAST don't ) + ) + +withCandidateIntersectionType + :: forall + ( rayQuery :: Symbol ) + ( a :: Type ) + ( i :: ProgramState ) + ( j1 :: ProgramState ) + ( j2 :: ProgramState ) + . ( Known Symbol rayQuery, PrimTy a ) + => Program ( RayQueryCandidateState rayQuery TriangleCandidateIntersection i ) j1 ( Code a ) + -> Program ( RayQueryCandidateState rayQuery AABBCandidateIntersection i ) j2 ( Code a ) + -> Program i i ( Code a ) +withCandidateIntersectionType withTriangle withAABB = + fromAST + ( SwitchM + ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionType ( RayQuery $ knownValue @rayQuery ) ( Just Candidate ) :: AST ( Eff i i Word32 ) ) + ( unsafeCoerce $ toAST withTriangle ) + [ ( 1, unsafeCoerce $ toAST withAABB ) ] + ) + +withCommittedIntersectionType + :: forall + ( rayQuery :: Symbol ) + ( a :: Type ) + ( i :: ProgramState ) + ( j1 :: ProgramState ) + ( j2 :: ProgramState ) + ( j3 :: ProgramState ) + . ( Known Symbol rayQuery, PrimTy a ) + => Program ( RayQueryCommittedState rayQuery NoIntersection i ) j1 ( Code a ) + -> Program ( RayQueryCommittedState rayQuery TriangleIntersection i ) j2 ( Code a ) + -> Program ( RayQueryCommittedState rayQuery GeneratedIntersection i ) j3 ( Code a ) + -> Program i i ( Code a ) +withCommittedIntersectionType noInter tri gen = + fromAST + ( SwitchM + ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionType ( RayQuery $ knownValue @rayQuery ) ( Just Committed ) :: AST ( Eff i i Word32 ) ) + ( unsafeCoerce $ toAST noInter ) + [ ( 1, unsafeCoerce $ toAST tri ) + , ( 2, unsafeCoerce $ toAST gen ) + ] + ) + +terminate + :: forall + ( rayQuery :: Symbol ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery ) + => Program i ( Terminate rayQuery i ) ( Code () ) +terminate = fromAST . ( unsafeCoerce :: AST ( Eff i i () ) -> AST ( Eff i ( Terminate rayQuery i ) () ) ) $ + ( RayQueryPrimOp (Proxy @()) SPIRV.Op.RayQueryTerminate ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i () ) ) + +generateIntersection + :: forall + ( rayQuery :: Symbol ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , CanGenerateIntersection rayQuery ( Lookup rayQuery ( RayQueries i ) ) + ) + => Code Float -> Program i i ( Code () ) +generateIntersection = fromAST + ( RayQueryPrimOp (Proxy @()) SPIRV.Op.RayQueryGenerateIntersection ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Val Float :--> Eff i i () ) ) + +confirmIntersection + :: forall + ( rayQuery :: Symbol ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , CanConfirmIntersection rayQuery ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code () ) +confirmIntersection = fromAST + ( RayQueryPrimOp (Proxy @()) SPIRV.Op.RayQueryConfirmIntersection ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i () ) ) + +getRayTMin + :: forall + ( rayQuery :: Symbol ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , HasRayQuery "getRayTMin" rayQuery ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code Float ) +getRayTMin = fromAST + ( RayQueryPrimOp (Proxy @Float) SPIRV.Op.RayQueryGetRayTMin ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i Float ) ) + +getRayFlags + :: forall + ( rayQuery :: Symbol ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , HasRayQuery "getRayFlags" rayQuery ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code Word32 ) +getRayFlags = fromAST + ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetRayFlags ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i Word32 ) ) + +getWorldRayDirection + :: forall + ( rayQuery :: Symbol ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , HasRayQuery "getWorldRayDirection" rayQuery ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code ( V 3 Float ) ) +getWorldRayDirection = fromAST + ( RayQueryPrimOp (Proxy @(V 3 Float)) SPIRV.Op.RayQueryGetWorldRayDirection ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i ( V 3 Float ) ) ) + +getWorldRayOrigin + :: forall + ( rayQuery :: Symbol ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , HasRayQuery "getWorldRayOrigin" rayQuery ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code ( V 3 Float ) ) +getWorldRayOrigin = fromAST + ( RayQueryPrimOp (Proxy @(V 3 Float)) SPIRV.Op.RayQueryGetWorldRayOrigin ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i ( V 3 Float ) ) ) + +getIntersectionCandidateAABBOpaque + :: forall + ( rayQuery :: Symbol ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , HasRayQuery "getIntersectionCandidateAABBOpaque" rayQuery ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code Bool ) +getIntersectionCandidateAABBOpaque = fromAST + ( RayQueryPrimOp (Proxy @Bool) SPIRV.Op.RayQueryGetIntersectionCandidateAABBOpaque ( RayQuery $ knownValue @rayQuery ) Nothing :: AST ( Eff i i Bool ) ) + +getIntersectionT + :: forall + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , Known IntersectionType interTy + , CanGetIntersectionT rayQuery interTy ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code Float ) +getIntersectionT = fromAST + ( RayQueryPrimOp (Proxy @Float) SPIRV.Op.RayQueryGetIntersectionT ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Float ) ) + +getIntersectionInstanceCustomIndex + :: forall + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , Known IntersectionType interTy + , HasSomeIntersection "getIntersectionInstanceCustomIndex" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code Word32 ) +getIntersectionInstanceCustomIndex = fromAST + ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionInstanceCustomIndex ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Word32 ) ) + +getIntersectionInstanceId + :: forall + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , Known IntersectionType interTy + , HasSomeIntersection "getIntersectionInstanceId" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code Word32 ) +getIntersectionInstanceId = fromAST + ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionInstanceId ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Word32 ) ) + +getIntersectionInstanceShaderBindingTableRecordOffset + :: forall + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , Known IntersectionType interTy + , HasSomeIntersection "getIntersectionInstanceShaderBindingTableRecordOffset" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code Word32 ) +getIntersectionInstanceShaderBindingTableRecordOffset = fromAST + ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionInstanceShaderBindingTableRecordOffset ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Word32 ) ) + +getIntersectionGeometryIndex + :: forall + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , Known IntersectionType interTy + , HasSomeIntersection "getIntersectionGeometryIndex" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code Word32 ) +getIntersectionGeometryIndex = fromAST + ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionGeometryIndex ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Word32 ) ) + +getIntersectionPrimitiveIndex + :: forall + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , Known IntersectionType interTy + , HasSomeIntersection "getIntersectionPrimitiveIndex" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code Word32 ) +getIntersectionPrimitiveIndex = fromAST + ( RayQueryPrimOp (Proxy @Word32) SPIRV.Op.RayQueryGetIntersectionPrimitiveIndex ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Word32 ) ) + +getIntersectionObjectRayDirection + :: forall + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , Known IntersectionType interTy + , HasSomeIntersection "getIntersectionObjectRayDirection" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code ( V 3 Float ) ) +getIntersectionObjectRayDirection = fromAST + ( RayQueryPrimOp (Proxy @(V 3 Float)) SPIRV.Op.RayQueryGetIntersectionObjectRayDirection ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i ( V 3 Float ) ) ) + +getIntersectionObjectRayOrigin + :: forall + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , Known IntersectionType interTy + , HasSomeIntersection "getIntersectionObjectRayOrigin" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code ( V 3 Float ) ) +getIntersectionObjectRayOrigin = fromAST + ( RayQueryPrimOp (Proxy @(V 3 Float)) SPIRV.Op.RayQueryGetIntersectionObjectRayOrigin ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i ( V 3 Float ) ) ) + +getIntersectionObjectToWorld + :: forall + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , Known IntersectionType interTy + , HasSomeIntersection "getIntersectionObjectToWorld" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code ( M 3 4 Float ) ) +getIntersectionObjectToWorld = fromAST + ( RayQueryPrimOp (Proxy @( M 3 4 Float)) SPIRV.Op.RayQueryGetIntersectionObjectToWorld( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i ( M 3 4 Float ) ) ) + +getIntersectionWorldToObject + :: forall + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , Known IntersectionType interTy + , HasSomeIntersection "getIntersectionWorldToObject" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code ( M 3 4 Float ) ) +getIntersectionWorldToObject = fromAST + ( RayQueryPrimOp (Proxy @( M 3 4 Float)) SPIRV.Op.RayQueryGetIntersectionWorldToObject ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i ( M 3 4 Float ) ) ) + +getIntersectionBarycentrics + :: forall + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , Known IntersectionType interTy + , HasSomeTriangleIntersection "getIntersectionBarycentrics" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code ( V 2 Float ) ) +getIntersectionBarycentrics = fromAST + ( RayQueryPrimOp (Proxy @(V 2 Float)) SPIRV.Op.RayQueryGetIntersectionBarycentrics ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i ( V 2 Float ) ) ) + +getIntersectionFrontFace + :: forall + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( i :: ProgramState ) + . ( Known Symbol rayQuery + , Known IntersectionType interTy + , HasSomeTriangleIntersection "getIntersectionFrontFace" rayQuery interTy ( Lookup rayQuery ( RayQueries i ) ) + ) + => Program i i ( Code Bool ) +getIntersectionFrontFace = fromAST + ( RayQueryPrimOp (Proxy @Bool) SPIRV.Op.RayQueryGetIntersectionFrontFace ( RayQuery $ knownValue @rayQuery ) ( Just $ knownValue @interTy ) :: AST ( Eff i i Bool ) ) diff --git a/src/FIR/Syntax/Swizzle.hs b/src/FIR/Syntax/Swizzle.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/Swizzle.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeAbstractions #-} + +{-| +Module: FIR.Syntax.Swizzle + +A swizzle is a way of remapping components of a vector, e.g.: + +> > view @(Swizzle "xyxz") (V3 1.0 2.0 3.0) +> V4 1.0 2.0 1.0 3.0 + +This is a convenience layer around the general type-level optics machinery +defined in "Control.Type.Optic", and more specifically a wrapper +around product optics, as @Swizzle "xyxz"@ desugars to the product optic + +> Prod ( Index 0 :*: Index 1 :*: Index 0 :*: Index 2 :*: EndProd ) + +The purpose of this module is simply to implement this desugaring. +-} + +module FIR.Syntax.Swizzle + ( Swizzle ) + where + +-- base +import Data.Kind + ( Type ) +import Data.Type.Bool + ( If ) +import Data.Type.Equality + ( type (==) ) +import GHC.TypeLits + ( Symbol + , TypeError, ErrorMessage(..) + ) + +-- fir +import Control.Type.Optic + ( Optic(..), Index + , ProductComponents(ProductO) + , EndProd + ) +import Data.Type.List + ( Length ) +import Data.Type.String + ( LookupTree + ( EnsureGTE, EnsureLT, Node, Leaf, Return ) + , LookupChars + ) +import FIR.AST + ( Code ) +import Math.Linear + ( V ) + +-------------------------------------------------------------------------------------------------- + +-- swizzle sets: xyzw rgba stpq +-- ASCII order: AB...G...PQRST...WXYZ...ab...g...pqrst...wxyz + +type SwizzleTree + = EnsureGTE "A" + ( EnsureLT "{" + ( Node "[" "`" + ( Node "G" "H" + ( Node "B" "C" + ( Leaf "A" ) + ( Node "D" "E" + ( Leaf "C" ) + Return + ) + ) + ( Node "U" "V" + ( Node "P" "Q" + Return + ( Node "R" "S" + ( Leaf "Q" ) + ( Node "T" "U" + ( Leaf "S" ) + Return + ) + ) + ) + ( Node "W" "X" + Return + ( Node "Y" "Z" + ( Leaf "X" ) + ( Leaf "Z" ) + ) + ) + ) + ) + ( Node "g" "h" + ( Node "b" "c" + ( Leaf "a" ) + ( Node "d" "e" + ( Leaf "c" ) + Return + ) + ) + ( Node "u" "v" + ( Node "p" "q" + Return + ( Node "r" "s" + ( Leaf "q" ) + ( Node "t" "u" + ( Leaf "s" ) + Return + ) + ) + ) + ( Node "w" "x" + Return + ( Node "y" "z" + ( Leaf "x" ) + ( Leaf "z" ) + ) + ) + ) + ) + ) + ) + +type Swizzle :: forall vec. forall (string :: Symbol) -> Optic '[] vec (SwizzleRes vec (LookupChars SwizzleTree string)) +type Swizzle @vec string + = Prod_ ( SwizzleFromString (LookupChars SwizzleTree string) ) + +-------------------------------------------------------------------------------------------------- + + +type family SwizzleRes (vec :: Type) (ks :: [Symbol]) :: Type where + SwizzleRes _ '[ ] = TypeError ( Text "Empty swizzle." ) + SwizzleRes vec '[k] = SwizzleComponent vec + SwizzleRes (V _ a) ks = V (Length ks) a + SwizzleRes (Code (V _ a)) ks = Code (V (Length ks) a) + SwizzleRes ty _ = + TypeError + ( Text "Cannot use swizzle on non-vector of type " :<>: ShowType ty :<>: Text "." ) + +type family SwizzleComponent (vec :: Type) :: Type where + SwizzleComponent (V _ a) = a + SwizzleComponent (Code (V _ a)) = Code a + SwizzleComponent ty = + TypeError + ( Text "Cannot use swizzle on non-vector of type " :<>: ShowType ty :<>: Text "." ) + +type family SwizzleComponents (vec :: Type) (ks :: [Symbol]) :: [Type] where + SwizzleComponents _ '[] = '[] + SwizzleComponents vec '[k] = '[ SwizzleComponent vec ] + SwizzleComponents vec (k1 ': k2 ': ks) = + SwizzleComponent vec ': SwizzleComponents vec (k2 ': ks) + +type family SwizzleFromChar (k :: Symbol) :: Optic '[] vec (SwizzleComponent vec) where + SwizzleFromChar "x" = Index 0 + SwizzleFromChar "X" = Index 0 + SwizzleFromChar "y" = Index 1 + SwizzleFromChar "Y" = Index 1 + SwizzleFromChar "z" = Index 2 + SwizzleFromChar "Z" = Index 2 + SwizzleFromChar "w" = Index 3 + SwizzleFromChar "W" = Index 3 + SwizzleFromChar "r" = Index 0 + SwizzleFromChar "R" = Index 0 + SwizzleFromChar "g" = Index 1 + SwizzleFromChar "G" = Index 1 + SwizzleFromChar "b" = Index 2 + SwizzleFromChar "B" = Index 2 + SwizzleFromChar "a" = Index 3 + SwizzleFromChar "A" = Index 3 + SwizzleFromChar "s" = Index 0 + SwizzleFromChar "S" = Index 0 + SwizzleFromChar "t" = Index 1 + SwizzleFromChar "T" = Index 1 + SwizzleFromChar "p" = Index 2 + SwizzleFromChar "P" = Index 2 + SwizzleFromChar "q" = Index 3 + SwizzleFromChar "Q" = Index 3 + SwizzleFromChar k = + TypeError + ( Text "Unsupported swizzle character " :<>: ShowType k :<>: Text "." + :$$: Text "Supported swizzle sets are: \"xyzw\", \"rgba\", \"stpq\"." + ) + +type SwizzleFromString :: forall vec. forall (swizzle :: [Symbol]) -> ProductComponents '[] vec (SwizzleComponents vec swizzle) +type family SwizzleFromString @vec swizzle where + SwizzleFromString '[ ] = EndProd + SwizzleFromString '[k] = SwizzleFromChar k `ProductO` EndProd + SwizzleFromString (k1 ': k2 ': ks) = + If ( SwizzleSet k1 == SwizzleSet k2 ) + ( SwizzleFromChar k1 `ProductO` SwizzleFromString (k2 ': ks) ) + ( TypeError + ( Text "Cannot mix and match different swizzle sets." + :$$: Text "Swizzle set of " :<>: ShowType k1 :<>: Text " is " + :<>: ShowType (SwizzleSet k1) :<>: Text "." + :$$: Text "Swizzle set of " :<>: ShowType k2 :<>: Text " is " + :<>: ShowType (SwizzleSet k2) :<>: Text "." + ) + ) + +type family SwizzleSet ( swizzle :: Symbol ) :: Symbol where + SwizzleSet "x" = "xyzw" + SwizzleSet "X" = "xyzw" + SwizzleSet "y" = "xyzw" + SwizzleSet "Y" = "xyzw" + SwizzleSet "z" = "xyzw" + SwizzleSet "Z" = "xyzw" + SwizzleSet "w" = "xyzw" + SwizzleSet "W" = "xyzw" + SwizzleSet "r" = "rgba" + SwizzleSet "R" = "rgba" + SwizzleSet "g" = "rgba" + SwizzleSet "G" = "rgba" + SwizzleSet "b" = "rgba" + SwizzleSet "B" = "rgba" + SwizzleSet "a" = "rgba" + SwizzleSet "A" = "rgba" + SwizzleSet "s" = "stpq" + SwizzleSet "S" = "stpq" + SwizzleSet "t" = "stpq" + SwizzleSet "T" = "stpq" + SwizzleSet "p" = "stpq" + SwizzleSet "P" = "stpq" + SwizzleSet "q" = "stpq" + SwizzleSet "Q" = "stpq" + SwizzleSet k + = TypeError + ( Text "Unsupported swizzle character detected in " :<>: ShowType k :<>: Text "." + :$$: Text "Supported swizzle sets are: \"xyzw\", \"rgba\", \"stpq\"." + ) diff --git a/src/FIR/Syntax/Synonyms.hs b/src/FIR/Syntax/Synonyms.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Syntax/Synonyms.hs @@ -0,0 +1,805 @@ +{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -Wno-missing-signatures #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeAbstractions #-} + +{-| +Module: FIR.Syntax.Synonyms + +This module provides various convenience synonyms +to mitigate verbosity in user-written programs. + +-} + +module FIR.Syntax.Synonyms + ( + -- * Synonyms for floating point types of a given width + Float16, Float32, Float64 + + -- * Synonyms for entry point globals with a given storage class + , UniformConstant, Input, Output + , Uniform, PushConstant + , StorageBuffer, Private + , Workgroup, CrossWorkgroup + , AtomicCounter + , RayPayload, RayPayloadIn + , CallableData, CallableDataIn + , HitAttribute, ShaderRecordBuffer + + -- * Synonyms for function with given function control information + , Function, Function' + + -- * Synonyms for images + -- ** Sampled images + , Texture1D, Texture2D, Texture3D, Texture + -- ** Storage images + , Image1D, Image2D, Image3D, StorageImage + , UnknownFormatImage1D, UnknownFormatImage2D, UnknownFormatImage3D + -- ** Image operand shorthands + , pattern DepthTestOffsets + , pattern GatherComponentWithOffsets + -- ** Helper type family for choosing image texel type + , FormatDefault + + -- * Synonyms involved in pipeline creation + , Slot + , pattern StructInput + + -- * Synonyms for optics + , Field + , Col, Cols + , Row, Rows + , Entry, Elts + , Diag, Center + + -- * Pattern synonyms for vectors/matrices + -- ** Patterns for vectors + , pattern Vec2, pattern Vec3, pattern Vec4 + + -- ** Patterns for matrices + , pattern Mat22, pattern Mat23, pattern Mat24 + , pattern Mat32, pattern Mat33, pattern Mat34 + , pattern Mat42, pattern Mat43, pattern Mat44 + + -- * Ray tracing flags + , pattern RayFlagsNone, pattern RayFlagsOpaque, pattern RayFlagsNoOpaque + , pattern RayFlagsTerminateOnFirstHit, pattern RayFlagsSkipClosestHitShader + , pattern RayFlagsCullBackFacingTriangles, pattern RayFlagsCullFrontFacingTriangles + , pattern RayFlagsCullOpaque, pattern RayFlagsCullNoOpaque + + -- * Ray tracing hit kinds + , pattern HitKindFrontFacingTriangle, pattern HitKindBackFacingTriangle + + ) + where + +-- base +import Prelude + hiding ( Floating, Integral ) +import Data.Int + ( Int8, Int16, Int32 ) +import Data.Kind + ( Type ) +import Data.Word + ( Word8, Word16, Word32 ) +import GHC.TypeLits + ( Symbol ) +import GHC.TypeNats + ( Nat, KnownNat + , type (*) + ) + +-- half +import Numeric.Half + ( Half ) + +-- fir +import Control.Type.Optic + ( Optic(..), Index + , (:.:), (:*:) + , OfType + , EndProd + ) +import Data.Type.Known + ( Known ) +import Data.Type.Map + ( (:->)((:->)), InsertionSort, Value ) +import FIR.AST + ( Code + , Syntactic(fromAST) + , pattern (:$) + , pattern MkVector, pattern Mat, pattern UnMat + , pattern Gather + ) +import FIR.Definition + ( Definition(Global) ) +import qualified FIR.Definition as Def +import FIR.Syntax.AST + ( ) +import FIR.Syntax.Optics + ( ) +import FIR.Layout + ( Layout(Locations) + , Poke(SizeOf) + ) +import FIR.Pipeline + ( PrimitiveTopology + , BindingStrides + , VertexLocationDescriptions + , PipelineInfo(VertexInputInfo) + , PipelineStages(VertexInput) + ) +import FIR.Prim.Array + ( Array ) +import FIR.Prim.Image + ( ImageProperties(Properties) + , ImageCoordinateKind(..) + , Image, GatherInfo(..) + ) +import FIR.Prim.Struct + ( Struct + , LocationSlot(LocationSlot) + ) +import FIR.Prim.Types + ( PrimTy, ScalarTy ) +import FIR.Validation.Bounds + ( StructIndexFromName ) +import FIR.Validation.Formats + ( ComputeFormats ) +import Math.Linear + ( V, M + , pattern V2, pattern V3, pattern V4 + ) +import SPIRV.ScalarTy + ( Signedness(..) ) +import SPIRV.Image + ( Dimensionality(..) + , HasDepth(..) + , Arrayness(..) + , MultiSampling(..) + , Normalisation(..) + , ImageUsage(..) + , ImageFormat(..) + ) +import SPIRV.Control + ( NoFunctionControl ) +import qualified SPIRV.Image as Image +import qualified SPIRV.Image as SPIRV + ( ImageFormat ) +import qualified SPIRV.Storage as Storage + +-------------------------------------------------------------------------- + +type Float16 = Half +type Float32 = Float +type Float64 = Double + +-- synonyms for (decorated) globals +type UniformConstant decs ty = Global Storage.UniformConstant decs ty +type Input decs ty = Global Storage.Input decs ty +type Output decs ty = Global Storage.Output decs ty +type Uniform decs ty = Global Storage.Uniform decs ty +type PushConstant decs ty = Global Storage.PushConstant decs ty +type StorageBuffer decs ty = Global Storage.StorageBuffer decs ty +type Private decs ty = Global Storage.Private decs ty +type Workgroup decs ty = Global Storage.Workgroup decs ty +type CrossWorkgroup decs ty = Global Storage.CrossWorkgroup decs ty +type AtomicCounter decs ty = Global Storage.AtomicCounter decs ty +type RayPayload decs ty = Global ( 'Storage.RayStorage ( Storage.RayPayload Storage.Lifetime ) ) decs ty +type RayPayloadIn decs ty = Global ( 'Storage.RayStorage ( Storage.RayPayload Storage.Incoming ) ) decs ty +type CallableData decs ty = Global ( 'Storage.RayStorage ( Storage.CallableData Storage.Lifetime ) ) decs ty +type CallableDataIn decs ty = Global ( 'Storage.RayStorage ( Storage.CallableData Storage.Incoming ) ) decs ty +type HitAttribute decs ty = Global ( 'Storage.RayStorage Storage.HitAttribute ) decs ty +type ShaderRecordBuffer decs ty = Global ( 'Storage.RayStorage Storage.ShaderRecordBuffer ) decs ty + +-- synonym for function with no function control information +type Function as b = Def.Function NoFunctionControl as b +type Function' fc as b = Def.Function fc as b + +-- synonyms for images +type Texture1D decs fmt + = Global Storage.UniformConstant + decs + ( Image + (Properties FloatingPointCoordinates (FormatDefault fmt) OneD (Just NotDepthImage) NonArrayed SingleSampled Sampled (Just fmt)) + ) +type Texture2D decs fmt + = Global Storage.UniformConstant + decs + ( Image + (Properties FloatingPointCoordinates (FormatDefault fmt) TwoD (Just NotDepthImage) NonArrayed SingleSampled Sampled (Just fmt)) + ) +type Texture3D decs fmt + = Global Storage.UniformConstant + decs + ( Image + (Properties FloatingPointCoordinates (FormatDefault fmt) ThreeD (Just NotDepthImage) NonArrayed SingleSampled Sampled (Just fmt)) + ) + +type Image1D decs fmt + = Global Storage.UniformConstant + decs + ( Image + (Properties IntegralCoordinates (FormatDefault fmt) OneD (Just NotDepthImage) NonArrayed SingleSampled Storage (Just fmt)) + ) +type Image2D decs fmt + = Global Storage.UniformConstant + decs + ( Image + (Properties IntegralCoordinates (FormatDefault fmt) TwoD (Just NotDepthImage) NonArrayed SingleSampled Storage (Just fmt)) + ) +type Image3D decs fmt + = Global Storage.UniformConstant + decs + ( Image + (Properties IntegralCoordinates (FormatDefault fmt) ThreeD (Just NotDepthImage) NonArrayed SingleSampled Storage (Just fmt)) + ) + +type UnknownFormatImage1D decs texel + = Global Storage.UniformConstant + decs + ( Image + (Properties IntegralCoordinates texel OneD (Just NotDepthImage) NonArrayed SingleSampled Storage Nothing) + ) +type UnknownFormatImage2D decs texel + = Global Storage.UniformConstant + decs + ( Image + (Properties IntegralCoordinates texel TwoD (Just NotDepthImage) NonArrayed SingleSampled Storage Nothing) + ) +type UnknownFormatImage3D decs texel + = Global Storage.UniformConstant + decs + ( Image + (Properties IntegralCoordinates texel ThreeD (Just NotDepthImage) NonArrayed SingleSampled Storage Nothing) + ) + +type Texture decs props + = Global + Storage.UniformConstant + decs + ( Image props ) +type StorageImage decs props + = Global + Storage.UniformConstant + decs + ( Image props ) + +-- shorthand pattern synonyms for image operands +pattern DepthTestOffsets offs ops = Gather (DepthWithOffsets offs) ops +pattern GatherComponentWithOffsets component offs ops + = Gather (ComponentWithOffsets component offs) ops + +----------------------------------------------------- +-- helper type family for choosing image texel type + +type family FormatDefault ( fmt :: ImageFormat Nat ) :: Type where + FormatDefault ('ImageFormat Image.Floating (16 ': _)) = Half + FormatDefault ('ImageFormat Image.Floating (_ ': _)) = Float + FormatDefault ('ImageFormat (Image.Integer Normalised _) _ ) = Float + FormatDefault ('ImageFormat (Image.Integer Unnormalised Signed ) ( 8 ': _ )) = Int8 + FormatDefault ('ImageFormat (Image.Integer Unnormalised Signed ) ( 16 ': _ )) = Int16 + FormatDefault ('ImageFormat (Image.Integer Unnormalised Signed ) ( _ ': _ )) = Int32 + FormatDefault ('ImageFormat (Image.Integer Unnormalised Unsigned) ( 8 ': _ )) = Word8 + FormatDefault ('ImageFormat (Image.Integer Unnormalised Unsigned) ( 16 ': _ )) = Word16 + FormatDefault ('ImageFormat (Image.Integer Unnormalised Unsigned) ( _ ': _ )) = Word32 + +----------------------------------------------------- +-- pipeline synonyms + +-- | Synonym for interface location slots. +type Slot (l :: Nat) (c :: Nat) = 'LocationSlot l c + +-- | Utility pattern synonym for specifying a simple kind of vertex input: +-- use a single array of structs to keep track of vertex data. +pattern StructInput + :: forall + ( as :: [LocationSlot Nat :-> Type] ) + ( top :: PrimitiveTopology Nat ) + ( descs :: VertexLocationDescriptions ) + ( stride :: Nat ) + ( strides :: BindingStrides ) + ( stageData :: Type ) + . ( descs ~ StructLocationDescriptions 0 as + , stride ~ SizeOf Locations (Struct as) + , strides ~ '[ 0 ':-> stride ] + , Known (PrimitiveTopology Nat) top + , Known VertexLocationDescriptions descs + , KnownNat stride + , Known BindingStrides strides + ) + => () + => PipelineStages (VertexInputInfo top descs strides) stageData +pattern StructInput = VertexInput + + +-- internal helper type synonyms / type families used for the above pattern synonym + +type StructLocationDescriptions ( bdNo :: Nat ) ( as :: [LocationSlot Nat :-> Type] ) + = ( AnnotateLocationsWithBindingAndOffset + bdNo + ( LocationDescriptionsOfStruct as ) + :: VertexLocationDescriptions + ) + +type family AnnotateLocationsWithBindingAndOffset + ( bdNo :: Nat ) + ( locationFormats :: [ Nat :-> SPIRV.ImageFormat Nat ] ) + :: [ Nat :-> ( Nat, Nat, SPIRV.ImageFormat Nat ) ] + where + AnnotateLocationsWithBindingAndOffset _ '[] = '[] + AnnotateLocationsWithBindingAndOffset bdNo + ( ( loc ':-> fmt ) ': locs ) + = ( loc ':-> '( bdNo, 16 * loc, fmt ) ) + ': AnnotateLocationsWithBindingAndOffset bdNo locs + +type LocationDescriptionsOfStruct + ( as :: [ LocationSlot Nat :-> Type ] ) + = ( ComputeFormats (InsertionSort as) :: [ Nat :-> SPIRV.ImageFormat Nat ] ) + +---------------------------------------------------------------------- +-- synonyms for optics + +type family FieldRes ( k :: Symbol ) ( struct :: Type ) :: Type where + FieldRes k (Struct as) = Value (StructIndexFromName k as) + FieldRes k (Code (Struct as)) = Code (Value (StructIndexFromName k as)) + +type Field :: forall struct. forall (k :: Symbol) -> Optic '[] struct (FieldRes k struct) +type family Field @struct k where + Field @(Struct as) k = Field_ k + Field @(Code (Struct as)) k = Field_ k + +-- internal synonyms to help inference in subsequent definitions +type Col_ :: forall (m :: Nat) (n :: Nat) a. Nat -> Optic '[] (M m n a) (V m a) +type Col_ i = Index i + +type Col__ :: forall (m :: Nat) (n :: Nat) a. Nat -> Optic '[] (Code (M m n a)) (Code (V m a)) +type Col__ i = Index i + +type Ix_ :: forall (n :: Nat) a. Nat -> Optic '[] (V n a) a +type Ix_ i = Index i + +type Ix__ :: forall (n :: Nat) a. Nat -> Optic '[] (Code (V n a)) (Code a) +type Ix__ i = Index i + +type family EltRes (t :: Type) :: Type where + EltRes (V m a) = a + EltRes (M m n a) = a + EltRes (Array n a) = a + EltRes (Code (V m a)) = Code a + EltRes (Code (M m n a)) = Code a + EltRes (Code (Array n a)) = Code a + +type Elts :: forall t. Optic '[] t (EltRes t) +type family Elts @t where + Elts @t = OfType (EltRes t) + +type family ColRes (mat :: Type) :: Type where + ColRes (Code (M m n a)) = Code (V m a) + ColRes (M m n a) = V m a + +type Col :: forall mat. Nat -> Optic '[] mat (ColRes mat) +type family Col i = optic | optic -> i where + Col @(Code (M m n a)) i = Col__ i + Col @(M m n a) i = Col_ i + +type Cols :: forall mat. Optic '[] mat (ColRes mat) +type family Cols @mat where + Cols @mat = OfType (ColRes mat) + +type family RowRes (mat :: Type) :: Type where + RowRes (M m n a) = V n a + RowRes (Code (M m n a)) = Code (V n a) + +type Row :: forall mat. Nat -> Optic '[] mat (RowRes mat) +type family Row i where + Row @(Code (M m 2 a)) i + = Prod_ + ( (Col__ 0 :.: Ix__ i) + :*: (Col__ 1 :.: Ix__ i) + :*: EndProd + ) + Row @(Code (M m 3 a)) i + = Prod_ + ( (Col__ 0 :.: Ix__ i) + :*: (Col__ 1 :.: Ix__ i) + :*: (Col__ 2 :.: Ix__ i) + :*: EndProd + ) + Row @(Code (M m 4 a)) i + = Prod_ + ( (Col__ 0 :.: Ix__ i) + :*: (Col__ 1 :.: Ix__ i) + :*: (Col__ 2 :.: Ix__ i) + :*: (Col__ 3 :.: Ix__ i) + :*: EndProd + ) + Row @(M m 2 a) i + = Prod_ + ( (Col_ 0 :.: Ix_ i) + :*: (Col_ 1 :.: Ix_ i) + :*: EndProd + ) + Row @(M m 3 a) i + = Prod_ + ( (Col_ 0 :.: Ix_ i) + :*: (Col_ 1 :.: Ix_ i) + :*: (Col_ 2 :.: Ix_ i) + :*: EndProd + ) + Row @(M m 4 a) i + = Prod_ + ( (Col_ 0 :.: Ix_ i) + :*: (Col_ 1 :.: Ix_ i) + :*: (Col_ 2 :.: Ix_ i) + :*: (Col_ 3 :.: Ix_ i) + :*: EndProd + ) + +type Rows :: forall mat. Optic '[] mat (RowRes mat) +type family Rows @mat where + Rows @(M 2 n a) + = ( Prod_ ( Row 0 :*: Row 1 :*: EndProd ) + :: Optic '[] (M 2 n a) (Struct '[ "row0" ':-> V n a, "row1" ':-> V n a]) ) + :.: OfType (V n a) + Rows @(M 3 n a) + = ( Prod_ ( Row 0 :*: Row 1 :*: Row 2 :*: EndProd ) + :: Optic '[] (M 3 n a) (Struct '[ "row0" ':-> V n a, "row1" ':-> V n a, "row2" ':-> V n a]) ) + :.: OfType (V n a) + Rows @(M 4 n a) + = ( Prod_ ( Row 0 :*: Row 1 :*: Row 2 :*: Row 3 :*: EndProd ) + :: Optic '[] (M 4 n a) (Struct '[ "row0" ':-> V n a, "row1" ':-> V n a, "row2" ':-> V n a, "row3" ':-> V n a ]) ) + :.: OfType (V n a) + Rows @(Code (M 2 n a)) + = ( Prod_ ( Row 0 :*: Row 1 :*: EndProd ) + :: Optic '[] (Code (M 2 n a)) (Struct '[ "row0" ':-> Code (V n a), "row1" ':-> Code (V n a)]) ) + :.: OfType (Code (V n a)) + Rows @(Code (M 3 n a)) + = ( Prod_ ( Row 0 :*: Row 1 :*: Row 2 :*: EndProd ) + :: Optic '[] (Code (M 3 n a)) (Struct '[ "row0" ':-> Code (V n a), "row1" ':-> Code (V n a), "row2" ':-> Code (V n a)]) ) + :.: OfType (Code (V n a)) + Rows @(Code (M 4 n a)) + = ( Prod_ ( Row 0 :*: Row 1 :*: Row 2 :*: Row 3 :*: EndProd ) + :: Optic '[] (Code (M 4 n a)) (Struct '[ "row0" ':-> Code (V n a), "row1" ':-> Code (V n a), "row2" ':-> Code (V n a), "row3" ':-> Code (V n a)]) ) + :.: OfType (Code (V n a)) + +type family EntryRes (mat :: Type) :: Type where + EntryRes (M m n a) = a + EntryRes (Code (M m n a)) = Code a + +type Entry :: forall mat. Nat -> Nat -> Optic '[] mat (EntryRes mat) +type family Entry i j where + Entry @(M m n a) i j = Col_ j :.: Ix_ i + Entry @(Code (M m n a)) i j = Col__ j :.: Ix__ i + +type family DiagRes (mat :: Type) :: Type where + DiagRes (M n n a) = V n a + DiagRes (Code (M n n a)) = Code (V n a) + +type Diag :: forall mat. Optic '[] mat (DiagRes mat) +type family Diag @mat where + Diag @(M 2 2 a) + = Prod_ + ( (Col_ 0 :.: Ix_ 0) + :*: (Col_ 1 :.: Ix_ 1) + :*: EndProd + ) + Diag @(M 3 3 a) + = Prod_ + ( (Col_ 0 :.: Ix_ 0) + :*: (Col_ 1 :.: Ix_ 1) + :*: (Col_ 2 :.: Ix_ 2) + :*: EndProd + ) + Diag @(M 4 4 a) + = Prod_ + ( (Col_ 0 :.: Ix_ 0) + :*: (Col_ 1 :.: Ix_ 1) + :*: (Col_ 2 :.: Ix_ 2) + :*: (Col_ 3 :.: Ix_ 3) + :*: EndProd + ) + Diag @(Code (M 2 2 a)) + = Prod_ + ( (Col__ 0 :.: Ix__ 0) + :*: (Col__ 1 :.: Ix__ 1) + :*: EndProd + ) + Diag @(Code (M 3 3 a)) + = Prod_ + ( (Col__ 0 :.: Ix__ 0) + :*: (Col__ 1 :.: Ix__ 1) + :*: (Col__ 2 :.: Ix__ 2) + :*: EndProd + ) + Diag @(Code (M 4 4 a)) + = Prod_ + ( (Col__ 0 :.: Ix__ 0) + :*: (Col__ 1 :.: Ix__ 1) + :*: (Col__ 2 :.: Ix__ 2) + :*: (Col__ 3 :.: Ix__ 3) + :*: EndProd + ) + +type Center :: forall mat. Optic '[] mat (EntryRes mat) +type family Center @mat where + Center @mat = Diag @mat :.: OfType (EntryRes mat) + +---------------------------------------------------------------------- +-- pattern synonyms for vectors/matrices + +-- these patterns could be generalised to have types such as: +-- Vec2 :: forall a. (Syntactic a, PrimTy (Internal a)) +-- => a -> a -> Code ( V 2 (Internal a) ) +-- but this leads to poor type-inference + +{-# COMPLETE Vec2 #-} +pattern Vec2 :: forall a. PrimTy a => Code a -> Code a -> Code ( V 2 a ) +pattern Vec2 x y <- (fromAST -> V2 x y) + where Vec2 x y = MkVector ( V2 x y ) + +{-# COMPLETE Vec3 #-} +pattern Vec3 :: forall a. PrimTy a => Code a -> Code a -> Code a -> Code ( V 3 a ) +pattern Vec3 x y z <- (fromAST -> V3 x y z) + where Vec3 x y z = MkVector ( V3 x y z ) + +{-# COMPLETE Vec4 #-} +pattern Vec4 :: forall a. PrimTy a => Code a -> Code a -> Code a -> Code a -> Code ( V 4 a ) +pattern Vec4 x y z w <- (fromAST -> V4 x y z w) + where Vec4 x y z w = MkVector ( V4 x y z w ) + +{-# COMPLETE Mat22 #-} +pattern Mat22 + :: ScalarTy a + => Code a -> Code a + -> Code a -> Code a + -> Code ( M 2 2 a ) +pattern Mat22 a11 a12 + a21 a22 + <- ( fromAST . ( UnMat :$ ) + -> V2 ( V2 a11 a21 ) + ( V2 a12 a22 ) + ) + where Mat22 + a11 a12 + a21 a22 + = Mat :$ Vec2 + ( Vec2 a11 a21 ) + ( Vec2 a12 a22 ) + +{-# COMPLETE Mat23 #-} +pattern Mat23 + :: ScalarTy a + => Code a -> Code a -> Code a + -> Code a -> Code a -> Code a + -> Code ( M 2 3 a ) +pattern Mat23 a11 a12 a13 + a21 a22 a23 + <- ( fromAST . ( UnMat :$ ) + -> V3 ( V2 a11 a21 ) + ( V2 a12 a22 ) + ( V2 a13 a23 ) + ) + where Mat23 + a11 a12 a13 + a21 a22 a23 + = Mat :$ Vec3 + ( Vec2 a11 a21 ) + ( Vec2 a12 a22 ) + ( Vec2 a13 a23 ) + +{-# COMPLETE Mat24 #-} +pattern Mat24 + :: ScalarTy a + => Code a -> Code a -> Code a -> Code a + -> Code a -> Code a -> Code a -> Code a + -> Code ( M 2 4 a ) +pattern Mat24 a11 a12 a13 a14 + a21 a22 a23 a24 + <- ( fromAST . ( UnMat :$ ) + -> V4 ( V2 a11 a21 ) + ( V2 a12 a22 ) + ( V2 a13 a23 ) + ( V2 a14 a24 ) + ) + where Mat24 + a11 a12 a13 a14 + a21 a22 a23 a24 + = Mat :$ Vec4 + ( Vec2 a11 a21 ) + ( Vec2 a12 a22 ) + ( Vec2 a13 a23 ) + ( Vec2 a14 a24 ) + +{-# COMPLETE Mat32 #-} +pattern Mat32 + :: ScalarTy a + => Code a -> Code a + -> Code a -> Code a + -> Code a -> Code a + -> Code ( M 3 2 a ) +pattern Mat32 a11 a12 + a21 a22 + a31 a32 + <- ( fromAST . ( UnMat :$ ) + -> V2 ( V3 a11 a21 a31 ) + ( V3 a12 a22 a32 ) + ) + where Mat32 + a11 a12 + a21 a22 + a31 a32 + = Mat :$ Vec2 + ( Vec3 a11 a21 a31 ) + ( Vec3 a12 a22 a32 ) + +{-# COMPLETE Mat33 #-} +pattern Mat33 + :: ScalarTy a + => Code a -> Code a -> Code a + -> Code a -> Code a -> Code a + -> Code a -> Code a -> Code a + -> Code ( M 3 3 a ) +pattern Mat33 a11 a12 a13 + a21 a22 a23 + a31 a32 a33 + <- ( fromAST . ( UnMat :$ ) + -> V3 ( V3 a11 a21 a31 ) + ( V3 a12 a22 a32 ) + ( V3 a13 a23 a33 ) + ) + where Mat33 + a11 a12 a13 + a21 a22 a23 + a31 a32 a33 + = Mat :$ Vec3 + ( Vec3 a11 a21 a31 ) + ( Vec3 a12 a22 a32 ) + ( Vec3 a13 a23 a33 ) + +{-# COMPLETE Mat34 #-} +pattern Mat34 + :: ScalarTy a + => Code a -> Code a -> Code a -> Code a + -> Code a -> Code a -> Code a -> Code a + -> Code a -> Code a -> Code a -> Code a + -> Code ( M 3 4 a ) +pattern Mat34 a11 a12 a13 a14 + a21 a22 a23 a24 + a31 a32 a33 a34 + <- ( fromAST . ( UnMat :$ ) + -> V4 ( V3 a11 a21 a31 ) + ( V3 a12 a22 a32 ) + ( V3 a13 a23 a33 ) + ( V3 a14 a24 a34 ) + ) + where Mat34 + a11 a12 a13 a14 + a21 a22 a23 a24 + a31 a32 a33 a34 + = Mat :$ Vec4 + ( Vec3 a11 a21 a31 ) + ( Vec3 a12 a22 a32 ) + ( Vec3 a13 a23 a33 ) + ( Vec3 a14 a24 a34 ) + +{-# COMPLETE Mat42 #-} +pattern Mat42 + :: ScalarTy a + => Code a -> Code a + -> Code a -> Code a + -> Code a -> Code a + -> Code a -> Code a + -> Code ( M 4 2 a ) +pattern Mat42 a11 a12 + a21 a22 + a31 a32 + a41 a42 + <- ( fromAST . ( UnMat :$ ) + -> V2 ( V4 a11 a21 a31 a41 ) + ( V4 a12 a22 a32 a42 ) + ) + where Mat42 + a11 a12 + a21 a22 + a31 a32 + a41 a42 + = Mat :$ Vec2 + ( Vec4 a11 a21 a31 a41 ) + ( Vec4 a12 a22 a32 a42 ) + +{-# COMPLETE Mat43 #-} +pattern Mat43 + :: ScalarTy a + => Code a -> Code a -> Code a + -> Code a -> Code a -> Code a + -> Code a -> Code a -> Code a + -> Code a -> Code a -> Code a + -> Code ( M 4 3 a ) +pattern Mat43 a11 a12 a13 + a21 a22 a23 + a31 a32 a33 + a41 a42 a43 + <- ( fromAST . ( UnMat :$ ) + -> V3 ( V4 a11 a21 a31 a41 ) + ( V4 a12 a22 a32 a42 ) + ( V4 a13 a23 a33 a43 ) + ) + where Mat43 + a11 a12 a13 + a21 a22 a23 + a31 a32 a33 + a41 a42 a43 + = Mat :$ Vec3 + ( Vec4 a11 a21 a31 a41 ) + ( Vec4 a12 a22 a32 a42 ) + ( Vec4 a13 a23 a33 a43 ) + +{-# COMPLETE Mat44 #-} +pattern Mat44 + :: ScalarTy a + => Code a -> Code a -> Code a -> Code a + -> Code a -> Code a -> Code a -> Code a + -> Code a -> Code a -> Code a -> Code a + -> Code a -> Code a -> Code a -> Code a + -> Code ( M 4 4 a ) +pattern Mat44 a11 a12 a13 a14 + a21 a22 a23 a24 + a31 a32 a33 a34 + a41 a42 a43 a44 + <- ( fromAST . ( UnMat :$ ) + -> V4 ( V4 a11 a21 a31 a41 ) + ( V4 a12 a22 a32 a42 ) + ( V4 a13 a23 a33 a43 ) + ( V4 a14 a24 a34 a44 ) + ) + where Mat44 + a11 a12 a13 a14 + a21 a22 a23 a24 + a31 a32 a33 a34 + a41 a42 a43 a44 + = Mat :$ Vec4 + ( Vec4 a11 a21 a31 a41 ) + ( Vec4 a12 a22 a32 a42 ) + ( Vec4 a13 a23 a33 a43 ) + ( Vec4 a14 a24 a34 a44 ) + +-- Ray flags. +pattern RayFlagsNone :: Word32 +pattern RayFlagsNone = 0 +pattern RayFlagsOpaque :: Word32 +pattern RayFlagsOpaque = 1 +pattern RayFlagsNoOpaque :: Word32 +pattern RayFlagsNoOpaque = 2 +pattern RayFlagsTerminateOnFirstHit :: Word32 +pattern RayFlagsTerminateOnFirstHit = 4 +pattern RayFlagsSkipClosestHitShader :: Word32 +pattern RayFlagsSkipClosestHitShader = 8 +pattern RayFlagsCullBackFacingTriangles :: Word32 +pattern RayFlagsCullBackFacingTriangles = 16 +pattern RayFlagsCullFrontFacingTriangles :: Word32 +pattern RayFlagsCullFrontFacingTriangles = 32 +pattern RayFlagsCullOpaque :: Word32 +pattern RayFlagsCullOpaque = 64 +pattern RayFlagsCullNoOpaque :: Word32 +pattern RayFlagsCullNoOpaque = 128 + +pattern HitKindFrontFacingTriangle :: Word32 +pattern HitKindFrontFacingTriangle = 0xfe +pattern HitKindBackFacingTriangle :: Word32 +pattern HitKindBackFacingTriangle = 0xff diff --git a/src/FIR/Temp.hs b/src/FIR/Temp.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Temp.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Temp + +Functionality for creating new (temporary) variable names at the type level. Currently unused. +-} + +module FIR.Temp + ( -- * Creating fresh temporary variable names + NewTemp + ) where + +-- base +import Data.Type.Bool + ( If ) +import GHC.TypeLits + ( Symbol, CmpSymbol, AppendSymbol ) +import GHC.TypeNats + ( type (+) ) + +-- fir +import Data.Type.Map + ( (:->)((:->)) ) +import Data.Type.String + ( ShowNat, ReadPrefixedNat ) + +------------------------------------------------------------------------------------------- +-- Creating fresh temporary variable names + +type TempPrefix = ( "__tmp" :: Symbol ) + +-- | Create a new temporary variable name. +type family NewTemp (i :: [Symbol :-> t]) :: Symbol where + NewTemp i = NextTemp (LastTemp i) + +type family NextTemp ( mbk :: Maybe Symbol ) :: Symbol where + NextTemp Nothing = TempPrefix `AppendSymbol` "0001" + NextTemp (Just k) + = TempPrefix `AppendSymbol` ( ShowNat (ReadPrefixedNat TempPrefix k + 1) ) + +--type family ReadTempNat ( k :: Symbol ) :: Nat where +-- ReadTempNat k = ReadPrefixedNat TempPrefix k + +type family LastTemp (i :: [Symbol :-> t]) :: Maybe Symbol where + LastTemp '[] = Nothing + LastTemp ( (k ':-> _) ': ks ) + = If ( InTempRange k ) + ( Just (LastInRange k ks) ) + ( LastTemp ks ) + +type family LastInRange (k :: Symbol) (i :: [Symbol :-> t]) :: Symbol where + LastInRange k '[] = k + LastInRange k ( (l ':-> _) ': ls) + = If ( InTempRange l ) + ( LastInRange l ls ) + k + +type family InTempRange (k :: Symbol) :: Bool where + InTempRange k + = InBetween + ( CmpSymbol k (TempPrefix `AppendSymbol` "0") ) + ( CmpSymbol k (TempPrefix `AppendSymbol` ":") ) + +type family InBetween (min :: Ordering) (max :: Ordering) :: Bool where + InBetween GT LT = True + InBetween _ _ = False diff --git a/src/FIR/Validation/Ambiguity.hs b/src/FIR/Validation/Ambiguity.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/Ambiguity.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.Ambiguity + +Contains some type errors that catch ambiguous type variables. + +This module is currently unused, as these ambiguity checks +seem to hinder more than they help, by preventing polymorphic +metaprogramming (unless the user passes additional constraints around). + +-} + +module FIR.Validation.Ambiguity where + +-- base +import Prelude + hiding ( Integral, Floating ) +import Data.Kind + ( Constraint ) +import GHC.TypeLits + ( Symbol + , TypeError, ErrorMessage(..) + ) + +-- fir +import Control.Type.Optic + ( Optic ) +import Data.Type.Map + ( (:->)((:->)) ) +import FIR.Binding + ( BindingsMap, Var ) +import qualified SPIRV.Stage as SPIRV + ( ExecutionModel ) + +------------------------------------------------- +-- * Checking for ambiguous type variables. + +data family Dummy :: k + +type family Assert ( err :: Constraint ) (ambig :: k) (x :: l) :: l where + Assert _ Dummy _ = Dummy + Assert _ _ l = l + +-- | Check that monadic state is not ambiguous. +type DefiniteState i = AssertDefiniteState i ( () :: Constraint ) + +type family AssertDefiniteState ( i :: BindingsMap ) (x :: l) :: l where + AssertDefiniteState i x = + AssertProvidedBindings + ( TypeError + ( Text "Ambiguous state in indexed monad." + :$$: Text "Potential causes:" + :$$: Text " - lack of a type signature indicating the starting monadic state," + :$$: Text " - an earlier overly general value (such as 'undefined') resulting in an ambiguous state." + :$$: Text " " + :$$: Text "If you are not expecting a specific state" + :$$: Text " ( for instance if you are writing a function which is polymorphic over monadic state )" + :$$: Text "add the constraint 'DefiniteState " :<>: ShowType i :<>: Text "' " + :<>: Text "to defer this error message to the use-site." + ) + ) + i + x + +type family AssertProvidedBindings ( err :: Constraint ) ( i :: BindingsMap ) (x :: l) :: l where + AssertProvidedBindings _ ( ("dummy" ':-> Var '[] Dummy) ': nxt) x = Dummy + AssertProvidedBindings err ( _ ': nxt) x = AssertProvidedBindings err nxt x + AssertProvidedBindings _ _ x = x + +-- | Check that a type-level symbol is not ambiguous. +type ProvidedSymbol k = AssertProvidedSymbol k ( () :: Constraint ) +type family AssertProvidedSymbol ( k :: Symbol ) (x :: l) :: l where + AssertProvidedSymbol k x = + Assert + ( TypeError + ( Text "Ambiguous type-level symbol." + :$$: Text "Suggestion: provide a specific name using a type application." + :$$: Text " " + :$$: Text "If you intend for " :<>: ShowType k :<>: Text " to remain un-instantiated," + :$$: Text "add the constraint 'ProvidedSymbol " :<>: ShowType k :<>: Text "' " + :<>: Text "to defer this error message to the use-site." + ) + ) + k + x + +-- | Check that a shader stage is not ambiguous. +type family ProvidedStage ( s :: SPIRV.ExecutionModel ) :: Constraint where + ProvidedStage s = + Assert + ( TypeError + ( Text "Ambiguous entry point stage." + :$$: Text "Suggestion: specify the stage using a type application." + :$$: Text " " + :$$: Text "If you intend for " :<>: ShowType s :<>: Text " to remain un-instantiated," + :$$: Text "add the constraint 'ProvidedStage " :<>: ShowType s :<>: Text "' " + :<>: Text "to defer this error message to the use-site." + ) + ) + s + ( () :: Constraint ) + +-- | Check that an optic is not ambiguous. +type family ProvidedOptic ( optic :: Optic is s a ) :: Constraint where + ProvidedOptic (optic :: Optic is s a) = + Assert + ( TypeError + ( Text "Ambiguous type-level optic." + :$$: Text "Suggestion: provide a specific optic using a type application." + :$$: Text "Expecting an optic:" + :$$: Text " - with run-time indices of types: " :<>: ShowType is + :$$: Text " - focusing within an object of type " :<>: ShowType s + :$$: Text " - onto an object of type " :<>: ShowType a + :$$: Text " " + :$$: Text "If " :<>: ShowType optic :<>: Text " is not intended to be a specific optic," + :$$: Text "for instance if you are writing an optic-polymorphic function," + :$$: Text "add the constraint 'ProvidedOptic " :<>: ShowType optic :<>: Text "' " + :<>: Text "to defer this error message to the use-site." + ) + ) + optic + ( () :: Constraint ) diff --git a/src/FIR/Validation/Arrayness.hs b/src/FIR/Validation/Arrayness.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/Arrayness.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.Arrayness + +Validation of implicit arrayness. + +Non-patch inputs to tessellation and geometry shaders, +and non-patch outputs of tessellation control shaders, +have an added layer of arrayness. + +This module checks for the presence of these layers of arrayness, +and provides type families to peel off such implicit arrayness layers. +-} + +module FIR.Validation.Arrayness where + +-- base +import Data.Kind + ( Type ) +import Data.Type.Bool + ( If ) +import GHC.TypeLits + ( Symbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.List + ( Elem ) +import Data.Type.String + ( ShowNat ) +import FIR.Prim.Array + ( Array ) +import qualified SPIRV.Decoration as SPIRV + ( Decoration(..) ) +import qualified SPIRV.Stage as SPIRV + ( ExecutionModel + , ExecutionInfo(..), ShaderInfo(..) + , NamedExecutionModel + ) +import qualified SPIRV.Storage as SPIRV + ( StorageClass(Input, Output) ) + +------------------------------------------------------------- + +data IsPatchVariable + = IsPatch + | NotPatch + +data ImplicitArrayness + = NoImplicitArrayness IsPatchVariable + | ImplicitArrayness Nat + +type family UnderlyingType + ( varName :: Symbol ) + ( inOut :: SPIRV.StorageClass ) + ( decs :: [ SPIRV.Decoration Nat ] ) + ( emName :: Symbol ) + ( ty :: Type ) + ( xnfo :: SPIRV.ExecutionInfo Nat em ) + :: Type + where + UnderlyingType varName inOut decs emName ty ( xnfo :: SPIRV.ExecutionInfo Nat em ) + = RemoveArrayness varName inOut emName em ty + ( Arrayness inOut decs xnfo ) + +type family Arrayness + ( inOut :: SPIRV.StorageClass ) + ( decs :: [ SPIRV.Decoration Nat ] ) + ( xnfo :: SPIRV.ExecutionInfo Nat em ) + :: ImplicitArrayness + where + Arrayness SPIRV.Input decs + ( SPIRV.ShaderExecutionInfo ( SPIRV.TessellationControlShaderInfo i _ _ ) ) + = If ( SPIRV.Patch `Elem` decs ) + ( 'NoImplicitArrayness IsPatch ) + ( 'ImplicitArrayness i ) + Arrayness SPIRV.Input decs + ( SPIRV.ShaderExecutionInfo ( SPIRV.TessellationEvaluationShaderInfo i _ ) ) + = If ( SPIRV.Patch `Elem` decs ) + ( 'NoImplicitArrayness IsPatch ) + ( 'ImplicitArrayness i ) + Arrayness SPIRV.Input decs + ( SPIRV.ShaderExecutionInfo ( SPIRV.GeometryShaderInfo i _ ) ) + = 'ImplicitArrayness i + Arrayness SPIRV.Output decs + ( SPIRV.ShaderExecutionInfo ( SPIRV.TessellationControlShaderInfo _ j _ ) ) + = If ( SPIRV.Patch `Elem` decs ) + ( 'NoImplicitArrayness IsPatch ) + ( 'ImplicitArrayness j ) + Arrayness _ _ _ = 'NoImplicitArrayness NotPatch + + +type family RemoveArrayness + ( varName :: Symbol ) + ( inOut :: SPIRV.StorageClass ) + ( emName :: Symbol ) + ( em :: SPIRV.ExecutionModel ) + ( ty :: Type ) + ( arrayness :: ImplicitArrayness ) + :: Type + where + RemoveArrayness _ _ _ _ ty (NoImplicitArrayness _) = ty + -- if an implicit level of arrayness is detected, + -- remove it (ignoring the specific array length, as Vulkan does) + RemoveArrayness _ _ _ _ (Array _ a) ('ImplicitArrayness _) = a + RemoveArrayness varName inOut emName em ty ('ImplicitArrayness i) + = TypeError + ( ShowType inOut :<>: Text " per-vertex variable " :<>: ShowType varName + :<>: Text " of " :<>: Text (SPIRV.NamedExecutionModel emName em) + :<>: Text " should be an array," + :$$: Text "but its type is " :<>: ShowType ty :<>: Text "." + ) + +type family ArraynessNote + ( em1 :: SPIRV.ExecutionModel ) + ( name1 :: Symbol ) + ( arrayness1 :: ImplicitArrayness ) + ( em2 :: SPIRV.ExecutionModel ) + ( name2 :: Symbol ) + ( arrayness2 :: ImplicitArrayness ) + :: ErrorMessage + where + ArraynessNote + em1 name1 ('ImplicitArrayness i1) + _ _ ('NoImplicitArrayness _) + = Text "" + :$$: Text "Note that per-vertex outputs of " + :<>: Text ( SPIRV.NamedExecutionModel name1 em1 ) + :<>: Text " must be arrays of size " :<>: Text (ShowNat i1) :<>: Text "." + ArraynessNote + _ _ ('NoImplicitArrayness _) + em2 name2 ('ImplicitArrayness i2) + = Text "" + :$$: Text "Note that per-vertex inputs of " + :<>: Text ( SPIRV.NamedExecutionModel name2 em2 ) + :<>: Text " must be arrays of size " :<>: Text (ShowNat i2) :<>: Text "." + ArraynessNote + em1 name1 ('ImplicitArrayness i1) + em2 name2 ('ImplicitArrayness i2) + = Text "" + :$$: Text "Note that:" + :$$: Text " - per-vertex outputs of " + :<>: Text ( SPIRV.NamedExecutionModel name1 em1 ) + :<>: Text " must be arrays of size " :<>: Text (ShowNat i1) :<>: Text "," + :$$: Text " - per-vertex inputs of " + :<>: Text ( SPIRV.NamedExecutionModel name2 em2 ) + :<>: Text " must be arrays of size " :<>: Text (ShowNat i2) :<>: Text "." + ArraynessNote + _ _ ('NoImplicitArrayness _) + _ _ ('NoImplicitArrayness _) + = Text "" diff --git a/src/FIR/Validation/Bindings.hs b/src/FIR/Validation/Bindings.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/Bindings.hs @@ -0,0 +1,709 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.Bindings + +Validation module providing checks for stateful operations +such as 'FIR.Syntax.Program.get' and 'FIR.Syntax.Program.put', +using type families with custom type errors. + +These are used, for instance, to prevent any name from being bound twice, +or accessing a binding that does not exist. + +-} + +module FIR.Validation.Bindings where + +-- base +import Prelude + hiding ( Integral, Floating ) +import Data.Kind + ( Type, Constraint ) +import Data.Type.Bool + ( If, type (||), type (&&) ) +import Data.Type.Equality + ( type (==) ) +import GHC.TypeLits + ( Symbol + , TypeError + , ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.Known + ( Known ) +import Data.Type.List + ( Elem ) +import Data.Type.Map + ( Map, (:->)((:->)) + , Insert, Remove + , Lookup, Union + , Keys + ) +import Data.Type.POrd + ( POrd(Compare) ) +import FIR.Binding + ( Binding, BindingsMap, FunctionType + , Permission(Read,Write) + , Var, Fun + ) +import FIR.Builtin + ( ModelBuiltins ) +import FIR.Prim.Types + ( HasOpaqueType ) +import FIR.ProgramState + ( FunctionContext(..) + , ProgramState(ProgramState) + , Definedness(..), FunctionInfo(..) + , EntryPointInfo(..), TLInterface + , Bindings + ) +import FIR.Validation.Interface + ( ValidInterface ) +import qualified SPIRV.Stage as SPIRV + ( ExecutionModel, NamedExecutionModel + , ExecutionInfo + , Backend, OtherBackend, BackendOf + ) + +------------------------------------------------- +-- * Lookup whether a binding exists in the monadic state. + +-- | Compute the type of a variable bound by a given name. +-- +-- Throws a type error if no variable by that name exists. +type family Has (k :: Symbol) (i :: ProgramState) :: Type where + Has k ('ProgramState bds _ _ _ _ _ _ _) = HasBinding k (Lookup k bds) + +type family HasBinding (k :: Symbol) (mbd :: Maybe Binding) :: Type where + HasBinding k 'Nothing + = TypeError + ( Text "No binding named " :<>: ShowType k :<>: Text " is in scope." ) + HasBinding k ('Just (Var _ a)) + = a + HasBinding _ ('Just (Fun as b)) = FunctionType as b + +------------------------------------------------- +-- * Constraints for 'FIR.Syntax.Program.get' and 'FIR.Syntax.Program.use' + +-- | Check whether we can 'get' a binding. +type family CanGet (k :: Symbol) (i :: ProgramState) :: Constraint where + CanGet k ('ProgramState bds _ _ _ _ _ _ _) = GetBinding k (Lookup k bds) + +type family GetBinding (k :: Symbol) (mbd :: Maybe Binding) :: Constraint where + GetBinding k 'Nothing + = TypeError + ( Text "'get'/'use': no binding named " :<>: ShowType k :<>: Text " is in scope." ) + GetBinding k ('Just (Var perms _)) + = If + ( Elem 'Read perms ) + ( () :: Constraint ) + ( TypeError + ( Text "'get'/'use': variable named " :<>: ShowType k :<>: Text " is not readable." ) + ) + GetBinding _ ('Just (Fun as b)) = () + +------------------------------------------------- +-- * Constraints for 'FIR.Syntax.Program.put' and 'FIR.Syntax.Program.assign' + +-- | Check whether we can write to a binding. +type family CanPut (k :: Symbol) (i :: ProgramState) :: Constraint where + CanPut k ('ProgramState bds _ _ _ _ _ _ _) = PutBinding k (Lookup k bds) + +type family PutBinding (k :: Symbol) (lookup :: Maybe Binding) :: Constraint where + PutBinding k 'Nothing = TypeError + ( Text "'put'/'assign': no binding named " :<>: ShowType k :<>: Text " is in scope." + :$$: Text "To bind a new variable, use 'def'." + ) + PutBinding k ('Just (Fun as b)) = TypeError + ( Text "'put'/'assign': function bound at name " + :<>: ShowType k :<>: Text ": " + :<>: ShowType (Fun as b) :<>: Text "." + :$$: Text "Use 'fundef' to define a function." + ) + PutBinding k ('Just (Var perms _)) + = If + ( Elem 'Write perms ) + ( () :: Constraint ) + ( TypeError + ( Text "'put'/'assign': variable " :<>: ShowType k :<>: Text " is not writable." ) + ) + +------------------------------------------------- +-- * Constraints for 'FIR.Syntax.Program.def' + +-- | Add a new binding to the indexed state. +type family AddBinding + ( k :: Symbol ) + ( bd :: Binding ) + ( s :: ProgramState ) + :: ProgramState where + AddBinding k bd ('ProgramState bds ctx cfg funs eps iface rayQueries bkend) + = 'ProgramState (Insert k bd bds) ctx cfg funs eps iface rayQueries bkend + +-- | Check that it is valid to define a new variable with given name. +-- +-- Throws a type error if a binding by this name already exists. +type family ValidDef (k :: Symbol) (i :: ProgramState) (a :: Type) :: Constraint where + ValidDef k ('ProgramState bds _ _ _ _ _ _ _) a = + ( NotAlreadyDefined k (Lookup k bds) + , NotOpaqueType (HasOpaqueType a) k a + ) + +type family NotAlreadyDefined (k :: Symbol) (lookup :: Maybe Binding) :: Constraint where + NotAlreadyDefined _ 'Nothing = () + NotAlreadyDefined k ('Just _) = TypeError + ( Text "'def': a binding by the name " :<>: ShowType k :<>: Text " already exists." ) + +type family NotOpaqueType (hasOpaque :: Bool) (k :: Symbol) (a :: Type) :: Constraint where + NotOpaqueType True k a = + TypeError + ( Text "'def': cannot define new binding named " :<>: ShowType k :<>: Text ":" + :$$: ShowType a :<>: Text " is an opaque type (or it contains an opaque type)." + ) + NotOpaqueType False _ _ = () + +------------------------------------------------- +-- * Constraints for 'FIR.Syntax.Program.fundef' + +-- | Indexed monadic state at start of function body. +-- +-- Adds the required function variables to the map of in-scope bindings. +type family FunctionDefinitionStartState + ( k :: Symbol ) + ( as :: BindingsMap ) + ( s :: ProgramState ) + = ( j :: ProgramState ) + | j -> k as + where + FunctionDefinitionStartState k as ('ProgramState i ctx cfg funs eps iface rayQueries bkend) + = 'ProgramState (Union i as) ('InFunction k as) cfg funs eps iface rayQueries bkend + +type family FunctionDefinitionEndState + ( k :: Symbol ) + ( as :: BindingsMap ) + ( bds :: BindingsMap ) + ( i :: ProgramState ) + = ( j :: ProgramState ) + | j -> k as bds + where + FunctionDefinitionEndState k as bds ('ProgramState _ _ cfg funs eps iface rayQueries bkend) + = 'ProgramState + bds + ( 'InFunction k as) + cfg + funs + eps + iface + rayQueries + bkend + +type family GetFunctionInfo + ( k :: Symbol ) + ( i :: ProgramState ) + :: FunctionInfo + where + GetFunctionInfo k ('ProgramState _ _ _ funs _ _ _ _) + = GetFunctionInfoFromLookup k (Lookup k funs) + +type family FunctionTypes + ( k :: Symbol ) + ( i :: ProgramState ) + :: ( BindingsMap, Type ) + where + FunctionTypes k i = FunctionTypesFromInfo (GetFunctionInfo k i) + +type family FunctionTypesFromInfo + ( info :: FunctionInfo ) + :: ( BindingsMap, Type ) + where + FunctionTypesFromInfo ('FunctionInfo as b _ _) = '( as, b ) + +type family GetFunctionInfoFromLookup + ( k :: Symbol ) + ( mbFun :: Maybe FunctionInfo ) + :: FunctionInfo + where + GetFunctionInfoFromLookup _ (Just info) = info + GetFunctionInfoFromLookup k 'Nothing + = TypeError + ( Text "'fundef': function named " :<>: ShowType k + :<>: Text " has not been declared (no function info)." + ) + +-- | Adds a function binding to the indexed monadic state. +type family AddFunBinding (k :: Symbol) (as :: BindingsMap) (b :: Type) (s :: ProgramState) :: ProgramState where + AddFunBinding k as b ('ProgramState bds ctx cfg funs eps iface rayQueries bkend) + -- 'ValidFunDef' should have already checked that name 'k' is not already in use + = 'ProgramState (Insert k (Fun as b) bds) ctx cfg (SetFunctionDefined k funs) eps iface rayQueries bkend + +type family SetFunctionDefined + ( k :: Symbol ) + ( funs :: Map Symbol FunctionInfo ) + :: Map Symbol FunctionInfo + where + SetFunctionDefined k '[] + = TypeError + ( Text "'fundef': function named " :<>: ShowType k + :<>: Text " has not been declared." + ) + SetFunctionDefined k ( ( k ':-> 'FunctionInfo as b fc Declared ) ': funs ) + = ( k ':-> 'FunctionInfo as b fc Defined ) ': funs + SetFunctionDefined k ( ( k ':-> 'FunctionInfo _ _ _ Defined ) ': _ ) + = TypeError + ( Text "'fundef': function named " :<>: ShowType k + :<>: Text " has already been defined." + ) + SetFunctionDefined k ( fun ': funs ) + = fun ': SetFunctionDefined k funs + +-- | Set the monadic context: within a function body. +type family SetFunctionContext + ( k :: Symbol ) + ( as :: BindingsMap ) + ( s :: ProgramState ) + :: ProgramState where + SetFunctionContext k as ('ProgramState bds TopLevel cfg funs eps iface rayQueries bkend) + = 'ProgramState bds ('InFunction k as) cfg funs eps iface rayQueries bkend + SetFunctionContext k _ ('ProgramState _ ('InFunction l _) _ _ _ _ _ _) + = TypeError + ( Text "'fundef': unexpected nested function definition." + :$$: Text "Function " :<>: ShowType k + :<>: Text " declared inside the body of function " :<>: ShowType l :<>: Text "." + ) + SetFunctionContext k _ + ( 'ProgramState _ ('InEntryPoint stageName ( _ :: SPIRV.ExecutionInfo Nat em) _) _ _ _ _ _ _ ) + = TypeError + ( Text "'fundef': unexpected function definition inside entry point." + :$$: Text "Function " :<>: ShowType k + :<>: Text " declared inside " :<>: Text (SPIRV.NamedExecutionModel stageName em) + :<>: Text "." + ) + +-- | Check that a function definition is valid. +-- +-- Throws a type error if: +-- +-- * function is not declared at the top level, +-- * function name is already in use, +-- * one of the function's arguments is itself a function, +-- * another function is defined inside the function, +type family ValidFunDef + ( k :: Symbol ) -- name of function to be defined + ( as :: BindingsMap ) -- function arguments + ( s :: ProgramState ) -- indexed state at the point the function is definition + ( l :: BindingsMap ) -- total bindings at the end of the function definition + :: Constraint + where + ValidFunDef k _ ('ProgramState _ ('InFunction l _) _ _ _ _ _ _ ) _ + = TypeError + ( Text "'fundef': unexpected nested function definition." + :$$: Text "Function " :<>: ShowType k + :<>: Text " declared inside the body of function " :<>: ShowType l :<>: Text "." + ) + ValidFunDef k _ + ( 'ProgramState _ ('InEntryPoint stageName ( _ :: SPIRV.ExecutionInfo Nat em) _) _ _ _ _ _ _) + _ + = TypeError + ( Text "'fundef': unexpected function definition inside entry point." + :$$: Text "Function " :<>: ShowType k + :<>: Text " declared inside " :<>: Text (SPIRV.NamedExecutionModel stageName em) + :<>: Text "." + ) + ValidFunDef k as ('ProgramState i 'TopLevel _ _ _ _ _ _) l + = ( NoFunctionNameConflict k ( Lookup k i ) -- check that function name is not already in use + , ValidArguments k as (Remove i (Remove as l)) ) + -- │ └━━━━━━┬━━━━━┘ + -- │ │ + -- │ │ + -- │ local variables ├━━━━━━━━┘ + -- │ + -- └━━┤ check that none of the function arguments or local variables are themselves functions or images + + +type ValidArguments (k :: Symbol) (as :: BindingsMap) (l :: BindingsMap) + = ( ValidArguments' k as l as l :: Constraint ) + +type family ValidArguments' + ( k :: Symbol ) + ( as :: BindingsMap ) + ( l :: BindingsMap ) + ( as_rec :: BindingsMap ) + ( l_rec :: BindingsMap ) + :: Constraint where + ValidArguments' _ _ _ '[] '[] = () + ValidArguments' k as _ ((v ':-> Fun _ _) ': _ ) _ = TypeError + ( Text "'fundef': forbidden higher order argument " :<>: ShowType v :<>: Text "," + :$$: Text "in function definition for " :<>: ShowType k :<>: Text "," + :$$: Text "when trying to abstract over:" + :$$: ShowType as + :$$: Text "Function definitions can only abstract over variables, not over functions." + ) + ValidArguments' k as l (_ ': as_rec) l_rec = ValidArguments' k as l as_rec l_rec + ValidArguments' k _ l _ ((v ':-> Fun _ _) ': _ ) = TypeError + ( Text "'fundef': unexpected nested function definition inside function " :<>: ShowType k :<>: Text ":" + :$$: Text "local name " :<>: ShowType v :<>: Text " binds a function." + :$$: Text "Local bindings for " :<>: ShowType k :<>: Text " are:" + :$$: ShowType l + ) + ValidArguments' k as l as_rec (_ ': l_rec) = ValidArguments' k as l as_rec l_rec + +type family NoFunctionNameConflict + ( k :: Symbol ) + ( mb_bd :: Maybe Binding ) -- conflict with in-scope variables? + :: Constraint where + NoFunctionNameConflict k ('Just _) = TypeError + ( Text "'fundef': cannot define a new function with name " :<>: ShowType k :<>: Text "." + :$$: Text "that name is already in scope." + ) + NoFunctionNameConflict _ 'Nothing = () + +------------------------------------------------- +-- * Constraints for 'FIR.Syntax.Program.entryPoint' + +-- | Check that an entry point definition is valid. +-- +-- Throws a type error if: +-- +-- * a function is defined within the entry point, +-- * the name of a builtin for this entry point is already in use. +type family ValidEntryPoint + ( k :: Symbol ) + ( nfo :: SPIRV.ExecutionInfo Nat s ) + ( i :: ProgramState ) + ( l :: BindingsMap ) + :: Constraint where + ValidEntryPoint k (nfo :: SPIRV.ExecutionInfo Nat s) ('ProgramState i _ _ _ eps _ _ bkend) l + = ( ValidInterface k ( LookupEntryPointInfo k s eps ) + , NoEntryPointNameConflict k (Lookup k i) + , ValidLocalBehaviour s (Remove i l) + , BuiltinsDoNotAppearBefore s (ModelBuiltins nfo) i + ) + +type family EntryPointsBackend + ( eps :: [ Symbol :-> ( SPIRV.ExecutionModel, modes ) ] ) + :: SPIRV.Backend + where + EntryPointsBackend '[] + = TypeError + ( Text "SPIR-V module must specify at least one entry point." + :$$: Text "Entry points are specified as part of a type signature containing module definitions." + :$$: Text "For instance, a fragment shader can be specified as follows:" + :$$: Text " \"main\" ':-> EntryPoint '[ OriginUpperLeft ] Fragment " + ) + EntryPointsBackend ( ( k ':-> '( s, _ ) ) ': eps ) + = CompatibleWithBackend k s (SPIRV.BackendOf s) eps + +type family CompatibleWithBackend + ( k :: Symbol ) + ( s :: SPIRV.ExecutionModel ) + ( bkend :: SPIRV.Backend ) + ( eps :: [ Symbol :-> ( SPIRV.ExecutionModel, modes ) ] ) + :: SPIRV.Backend + where + CompatibleWithBackend _ _ bk '[] = bk + CompatibleWithBackend k s bk ( ( k' ':-> '( s', _ ) ) ': eps ) + = If ( SPIRV.BackendOf s' == bk ) + ( CompatibleWithBackend k s bk eps ) + ( TypeError + ( Text "Incompatible backends." + :$$: Text ( SPIRV.NamedExecutionModel k s ) + :<>: Text " uses " :<>: ShowType bk :<>: Text "," + :$$: Text "while " :<>: Text ( SPIRV.NamedExecutionModel k' s' ) + :<>: Text " uses " :<>: ShowType ( SPIRV.OtherBackend bk ) :<>: Text "." + ) + ) + + +-- | Indexed monadic state at start of entry point body. +type family EntryPointStartState + ( k :: Symbol ) + ( nfo :: SPIRV.ExecutionInfo Nat s ) + ( i :: ProgramState ) + = ( j :: ProgramState ) + | j -> k nfo + where + EntryPointStartState k nfo ('ProgramState bds _ cfg funs eps g_iface _ bkend) + = 'ProgramState + ( Union bds (ModelBuiltins nfo) ) -- bindings at the beginning + ( 'InEntryPoint -- context: now within an entry point + k + nfo + ( 'Just '[] ) -- initial empty interface + ) + cfg + funs + eps + g_iface + '[] -- no ray queries to start off with + bkend + +-- | Indexed monadic state at end of entry point body. +type family EntryPointEndState + ( k :: Symbol ) + ( nfo :: SPIRV.ExecutionInfo Nat s ) + ( bds :: BindingsMap ) + ( iface :: TLInterface ) + ( i :: ProgramState ) + = ( j :: ProgramState ) + | j -> k nfo bds iface + where + EntryPointEndState k nfo bds iface ('ProgramState _ _ cfg funs eps g_iface rayQueries bkend) + = 'ProgramState + bds + ( InEntryPoint k nfo ('Just iface) ) + cfg + funs + eps + g_iface + rayQueries + bkend + +type family GetExecutionInfo + ( k :: Symbol ) + ( em :: SPIRV.ExecutionModel ) + ( i :: ProgramState ) + :: SPIRV.ExecutionInfo Nat em + where + GetExecutionInfo k em ('ProgramState _ _ _ _ eps _ _ _) + = GetExecutionInfoOf k em eps + +type family GetExecutionInfoOf + ( k :: Symbol ) + ( em :: SPIRV.ExecutionModel ) + ( i :: [ Symbol :-> EntryPointInfo ] ) + :: SPIRV.ExecutionInfo Nat em + where + GetExecutionInfoOf k em '[] + = TypeError + ( Text "'GetExecutionInfo': cannot find " + :<>: Text (SPIRV.NamedExecutionModel k em) + :<>: Text "." + ) + GetExecutionInfoOf k em + ( ( k ':-> 'EntryPointInfo (nfo :: SPIRV.ExecutionInfo Nat em) _ _ ) ': _ ) + = nfo + GetExecutionInfoOf k em (_ ': eps) + = GetExecutionInfoOf k em eps + + +type family SetInterface + ( k :: Symbol ) + ( nfo :: SPIRV.ExecutionInfo Nat s ) + ( iface :: TLInterface ) + ( i :: ProgramState ) + :: ProgramState + where + SetInterface k (nfo :: SPIRV.ExecutionInfo Nat s) iface ('ProgramState i fc cfg funs eps globalIface rayQueries bkend) + = 'ProgramState i fc cfg funs (SetInterfaceOf k s iface eps) globalIface rayQueries bkend + +type family SetInterfaceOf + ( k :: Symbol ) + ( em :: SPIRV.ExecutionModel ) + ( iface :: TLInterface ) + ( eps :: [ Symbol :-> EntryPointInfo ] ) + :: [ Symbol :-> EntryPointInfo ] + where + SetInterfaceOf k em _ '[] + = TypeError + ( Text "'SetInterface': cannot find " + :<>: Text (SPIRV.NamedExecutionModel k em) + :<>: Text "." + ) + SetInterfaceOf k em iface + ( ( k ':-> 'EntryPointInfo (nfo :: SPIRV.ExecutionInfo Nat em) _ Declared ) ': eps ) + = ( k ':-> 'EntryPointInfo nfo iface Defined ) ': eps + SetInterfaceOf k em iface + ( (k ':-> 'EntryPointInfo (nfo :: SPIRV.ExecutionInfo Nat em) _ Defined ) ': _ ) + = TypeError + ( Text "'entryPoint': entry point " + :<>: Text (SPIRV.NamedExecutionModel k em) + :<>: Text " has already been defined." + ) + SetInterfaceOf k em iface (ep ': eps) + = ep ': SetInterfaceOf k em iface eps + +type family InsertEntryPointInfo + ( k :: Symbol ) + ( nfo :: EntryPointInfo ) + ( eps :: [ Symbol :-> EntryPointInfo ] ) + :: [ Symbol :-> EntryPointInfo ] + where + InsertEntryPointInfo k nfo '[] + = '[ k ':-> nfo ] + InsertEntryPointInfo k + ( 'EntryPointInfo (nfo :: SPIRV.ExecutionInfo Nat s1) iface def) + ( ( l ':-> 'EntryPointInfo (nfo2 :: SPIRV.ExecutionInfo Nat s2) iface2 def2 ) ': eps ) + = InsertEntryPointInfoWithComparison + ( k `Compare` l ) + ( s1 `Compare` s2 ) + k ( 'EntryPointInfo nfo iface def ) + l ( 'EntryPointInfo nfo2 iface2 def2 ) + eps + +type family InsertEntryPointInfoWithComparison + ( cmpName :: Ordering ) + ( cmpStage :: Ordering ) + ( name1 :: Symbol ) + ( nfo1 :: EntryPointInfo ) + ( name2 :: Symbol ) + ( nfo2 :: EntryPointInfo ) + ( nfos :: [ Symbol :-> EntryPointInfo ] ) + :: [ Symbol :-> EntryPointInfo ] + where + -- NB: duplicate declarations are reported by 'FIR.Validation.Definitions.ValidDefinitions'. + InsertEntryPointInfoWithComparison EQ EQ + _ _ + name2 nfo2 + nfos + = ( name2 ':-> nfo2 ) ': nfos + InsertEntryPointInfoWithComparison cmpName cmpStage name1 nfo1 name2 nfo2 nfos + = If ( cmpName == LT || ( cmpName == EQ && cmpStage == LT ) ) + ( ( name1 ':-> nfo1 ) ': ( name2 ':-> nfo2 ) ': nfos ) + ( ( name2 ':-> nfo2 ) ': InsertEntryPointInfo name1 nfo1 nfos ) + +type family LookupEntryPointInfo + ( name :: Symbol ) + ( em :: SPIRV.ExecutionModel ) + ( eps :: [ Symbol :-> EntryPointInfo ] ) + :: EntryPointInfo + where + LookupEntryPointInfo name em + ( ( name ':-> 'EntryPointInfo ( nfo :: SPIRV.ExecutionInfo Nat em ) iface defi ) ': _ ) + = 'EntryPointInfo nfo iface defi + LookupEntryPointInfo name em ( _ ': eps ) = LookupEntryPointInfo name em eps + LookupEntryPointInfo name em '[] + = TypeError + ( Text "'entryPoint': cannot define " + :<>: Text (SPIRV.NamedExecutionModel name em) :<>: Text "." + :$$: Text "No such entry point has been declared in the top-level definitions of the program." + ) + +type family NoEntryPointNameConflict + ( k :: Symbol ) + ( mb_bd :: Maybe Binding ) + :: Constraint where + NoEntryPointNameConflict k ('Just _) = TypeError + ( Text "'entryPoint': cannot define a new entry point with name " :<>: ShowType k :<>: Text "." + :$$: Text "That name is already in scope." + ) + NoEntryPointNameConflict _ 'Nothing = () + +type ValidLocalBehaviour (s :: SPIRV.ExecutionModel) (l :: BindingsMap) + = ( ValidLocalBehaviour' s l l :: Constraint ) + +type family ValidLocalBehaviour' + ( s :: SPIRV.ExecutionModel ) + ( l :: BindingsMap ) + ( l_rec :: BindingsMap ) + :: Constraint where + ValidLocalBehaviour' _ _ '[] = () + ValidLocalBehaviour' s l ((_ ':-> Var _ _) ': l_rec) = ValidLocalBehaviour' s l l_rec + ValidLocalBehaviour' s l ((v ':-> Fun _ _) ': _ ) = TypeError + ( Text "'entryPoint': unexpected nested function definition inside " :<>: ShowType s :<>: Text " entry point:" + :$$: Text "local name " :<>: ShowType v :<>: Text "binds a function." + :$$: Text "Local bindings for " :<>: ShowType s :<>: Text " entry point are:" + :$$: ShowType l + ) + +type family BuiltinsDoNotAppearBefore + ( s :: SPIRV.ExecutionModel ) + ( builtins :: BindingsMap ) + ( i :: BindingsMap ) + :: Constraint where + BuiltinsDoNotAppearBefore _ '[] _ = () + BuiltinsDoNotAppearBefore s ((b ':-> _) ': bs) i + = BuiltinDoesNotAppearBefore s b bs i (Lookup b i) + +type family BuiltinDoesNotAppearBefore + ( s :: SPIRV.ExecutionModel ) + ( b :: Symbol ) + ( bs :: BindingsMap ) + ( i :: BindingsMap ) + ( lkp :: Maybe Binding ) + :: Constraint where + BuiltinDoesNotAppearBefore s _ bs i 'Nothing = BuiltinsDoNotAppearBefore s bs i + BuiltinDoesNotAppearBefore s b _ i ('Just _) + = TypeError ( Text "'entryPoint': conflict with built-in variable for " :<>: ShowType s :<>: Text " stage." + :$$: Text "Variable with name " :<>: ShowType b :<>: Text " is a built-in, yet is already bound." + :$$: Text "Variables in scope at site of entry point definition are:" + :$$: ShowType i + ) + +------------------------------------------------- +-- * Constraints for 'FIR.Syntax.Program.embed'. + +class Known [Symbol] (Keys (Bindings i)) => Embeddable (i :: ProgramState) (j :: ProgramState) where +instance ( Known [Symbol] (Keys (Bindings i)), CanEmbed i j ) => Embeddable i j where + +type family CanEmbed (i :: ProgramState) (j :: ProgramState) :: Constraint where + CanEmbed ('ProgramState '[] 'TopLevel _ '[] _ _ _ _) _ = () + CanEmbed ('ProgramState i_bds i_ctx _ i_funs _ _ _ _) ('ProgramState j_bds i_ctx _ j_funs _ _ _ _) + = ( SubsetBindings i_bds j_bds + , SubsetFunctions i_funs j_funs + ) + CanEmbed ('ProgramState _ i_ctx _ _ _ _ _ _) ('ProgramState _ j_ctx _ _ _ _ _ _) + = TypeError + ( Text "'embed': cannot embed computation with function context " + :<>: ShowType i_ctx + :<>: Text " into computation with function context " + :<>: ShowType j_ctx + :<>: Text "." + ) + +type family SubsetBindings (is :: BindingsMap) (js :: BindingsMap) :: Constraint where + SubsetBindings '[] _ = () + SubsetBindings (i ': is) js + = If (i `Elem` js) + ( SubsetBindings is js ) + ( TypeError + ( Text "'embed': cannot embed computation." + :$$: Text "Binding " :<>: ShowType i + :<>: Text " is missing in larger context " + :<>: ShowType js + :<>: Text "." + ) + ) + +type family SubsetFunctions + ( fs :: Map Symbol FunctionInfo ) + ( gs :: Map Symbol FunctionInfo ) + :: Constraint where + SubsetFunctions '[] _ = () + SubsetFunctions ( (k ':-> f) ': fs) gs + = SubsetFunctionsRec k f (Lookup k gs) fs gs + +type family SubsetFunctionsRec + ( k :: Symbol ) + ( f :: FunctionInfo ) + ( g :: Maybe FunctionInfo ) + ( fs :: Map Symbol FunctionInfo ) + ( gs :: Map Symbol FunctionInfo ) + :: Constraint where + SubsetFunctionsRec k _ Nothing _ _ + = TypeError + ( Text "'embed': cannot embed computation." + :$$: Text "Function named " :<>: ShowType k + :<>: Text " is missing in larger context." + ) + SubsetFunctionsRec _ f (Just f) fs gs + = SubsetFunctions fs gs + SubsetFunctionsRec k f (Just f') _ _ + = TypeError + ( Text "'embed': cannot embed computation." + :$$: Text "Mismatch between functions of name " :<>: ShowType k + :<>: Text "." + :$$: Text " - Smaller context function info: " :<>: ShowType f :<>: Text "," + :$$: Text " - Larger context function info: " :<>: ShowType f' :<>: Text "." + ) diff --git a/src/FIR/Validation/Bounds.hs b/src/FIR/Validation/Bounds.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/Bounds.hs @@ -0,0 +1,113 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.Bounds + +Custom error messages for out-of bounds indexing operations. + +-} + +module FIR.Validation.Bounds + ( VectorIndexInBounds, MatrixColumnIndexInBounds + , ArrayIndexInBounds + , StructFieldFromIndex, StructIndexFromName + ) + where + +-- base +import Data.Kind + ( Constraint ) +import GHC.TypeLits + ( TypeError + , ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat, CmpNat, type (+) ) + +-- fir +import Data.Type.List + ( AtIndex, Length ) +import Data.Type.Map + ( (:->)((:->)) ) +import Data.Type.Maybe + ( FromJust ) + +--------------------------------------------------------------------------------------------- + +type family ErrorIfNotLT (n :: Nat) (i :: Nat) (msg :: ErrorMessage) :: Constraint where + ErrorIfNotLT n i msg = ErrorIfNotLT_Helper msg (CmpNat i n) + +type family ErrorIfNotLT_Helper (msg :: ErrorMessage) (cmp :: Ordering) :: Constraint where + ErrorIfNotLT_Helper _ LT = ( () :: Constraint ) + ErrorIfNotLT_Helper msg _ = TypeError msg + +type family VectorIndexInBounds (n :: Nat) (i :: Nat) :: Constraint where + VectorIndexInBounds n i + = ErrorIfNotLT n i + ( Text "Vector index " + :<>: ShowType i + :<>: Text " is out of bounds." + :$$: Text "Vector dimension is " + :<>: ShowType n :<>: Text "." + :$$: Text "Note: indexing starts from 0." + ) + +type family MatrixColumnIndexInBounds (m :: Nat) (n :: Nat) (i :: Nat) :: Constraint where + MatrixColumnIndexInBounds m n i + = ErrorIfNotLT n i + ( Text "Matrix column index " + :<>: ShowType i + :<>: Text " is out of bounds." + :$$: Text "This matrix has " + :<>: ShowType m :<>: Text " rows, " + :<>: ShowType n :<>: Text " columns." + :$$: Text "Note: indexing starts from 0." + ) + +type family ArrayIndexInBounds (n :: Nat) (i :: Nat) :: Constraint where + ArrayIndexInBounds n i + = ErrorIfNotLT n i + ( Text "Array index " + :<>: ShowType i + :<>: Text " is out of bounds." + :$$: Text "Array size is " + :<>: ShowType n :<>: Text "." + :$$: Text "Note: indexing starts from 0." + ) + +type family StructFieldFromIndex (i :: Nat) (as :: [fld :-> ty]) :: ( fld :-> ty ) where + StructFieldFromIndex i as = + FromJust (AtIndex i as) + ( Text "Index " + :<>: ShowType i + :<>: Text " out of bounds when accessing structure with fields" + :$$: ShowType as + :$$: Text "Structure has only " :<>: ShowType (Length as) + :<>: Text " fields." + :$$: Text "Note: indexing starts from 0." + ) + +type family StructIndexFromName (k :: fld) (as :: [fld :-> ty]) :: ( Nat :-> ty ) where + StructIndexFromName k as = StructIndexFromNameRec k as 0 as + +type family StructIndexFromNameRec + (k :: fld) (as :: [fld :-> ty]) + (i :: Nat) (as_rec :: [fld :-> ty]) + :: ( Nat :-> ty ) + where + StructIndexFromNameRec k _ i ((k ':-> a)': _) = (i ':-> a) + StructIndexFromNameRec k as i ( _ ': as_rec) = StructIndexFromNameRec k as (i+1) as_rec + StructIndexFromNameRec k as _ '[] + = ( TypeError + ( Text "Structure has no field with name " + :<>: ShowType k :<>: Text "." + :$$: Text "This structure has the following fields:" + :$$: ShowType as + ) + ) diff --git a/src/FIR/Validation/CFG.hs b/src/FIR/Validation/CFG.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/CFG.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.CFG + +Validation module providing checks for control-flow based operations. + +-} + +module FIR.Validation.CFG + ( InLoop + , ValidBreak, ValidContinue + ) + where + +-- base +import Data.Kind + ( Constraint ) +import GHC.TypeLits + ( TypeError + , ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat, CmpNat ) + +-- fir +import Data.Type.Nat + ( Succ ) +import FIR.ProgramState + ( ProgramState(ProgramState), CFGState(..) ) + +------------------------------------------------- + +-- | The program state within the body of a loop (see 'FIR.Syntax.Program.while' +-- and 'FIR.Syntax.Program.loop'): the loop nesting level is one higher. +-- +-- A combinator which runs a user-supplied computation within a loop, e.g. once for +-- each element of a collection, takes a computation of type @Program (InLoop i) (InLoop i) a@. +type family InLoop ( i :: ProgramState ) = ( i' :: ProgramState ) | i' -> i where + InLoop ( 'ProgramState bds ctx cfg funs eps iface rayQueries bk ) = + 'ProgramState bds ctx ( CFGStateAddLoop cfg ) funs eps iface rayQueries bk + +type family CFGStateAddLoop ( cfg :: CFGState ) = ( cfg' :: CFGState ) | cfg' -> cfg where + CFGStateAddLoop ( 'CFGState currLoopLevel ) = 'CFGState ( Succ currLoopLevel ) + + +-- | Check whether a break statement is valid. +type family ValidBreak ( n :: Nat ) ( i :: ProgramState ) :: Constraint where + ValidBreak 0 _ = () + ValidBreak n ( 'ProgramState _ _ ('CFGState currLoopDepth) _ _ _ _ _ ) = + EnsureValidBreakNb n currLoopDepth ( n `CmpNat` currLoopDepth ) + +type family EnsureValidBreakNb ( n :: Nat ) ( currLoopDepth :: Nat ) ( cmp :: Ordering ) :: Constraint where + EnsureValidBreakNb n currLoopDepth GT = + TypeError + ( Text "Cannot break out of " :<>: ShowType n :<>: Text " loops." + :$$: Text "Current loop nesting level is only " :<>: ShowType currLoopDepth :<>: Text "." + ) + EnsureValidBreakNb _ _ _ = () + +-- | Check whether a continue statement is valid. +type family ValidContinue ( n :: Nat ) ( i :: ProgramState ) :: Constraint where + ValidContinue n ( 'ProgramState _ _ ('CFGState currLoopDepth) _ _ _ _ _ ) = + EnsureValidBreakContinue n currLoopDepth ( n `CmpNat` currLoopDepth ) + +type family EnsureValidBreakContinue ( n :: Nat ) ( currLoopDepth :: Nat ) ( cmp :: Ordering ) :: Constraint where + EnsureValidBreakContinue _ _ LT = () + EnsureValidBreakContinue 0 currLoopDepth _ = + TypeError + ( Text "Unexpected 'continue' statement: not inside a loop" ) + EnsureValidBreakContinue n currLoopDepth _ = + TypeError + ( Text "'breakContinue': cannot continue after breaking out of " :<>: ShowType n :<>: Text " loops." + :$$: Text "Current loop nesting level is only " :<>: ShowType currLoopDepth :<>: Text "." + ) diff --git a/src/FIR/Validation/Definitions.hs b/src/FIR/Validation/Definitions.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/Definitions.hs @@ -0,0 +1,412 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.Definitions + +Validate individual top-level "FIR.Definition.Definition"s. + +For instance, this checks that uniform buffer objects are +decorated with the required binding and descriptor set indices. + +Does __not__ perform validation of entry point interfaces, +i.e. input/output variables. See "FIR.Validation.Interface". +This is because it is not possible to validate layout using only the definitions, +as the layout validity of an entry point interface depends on +the specific entry-point it is used by. +For instance, an arrayed input means something different in +a tessellation evaluation shader than in a vertex shader, +because of implicit arrayness levels. See "FIR.Validation.Arrayness". + +-} + +module FIR.Validation.Definitions + ( ValidDefinitions ) + where + +-- base +import Data.Kind + ( Type, Constraint ) +import GHC.TypeLits + ( Symbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.Maybe + ( FromMaybe ) +import Data.Type.Map + ( (:->)((:->)), Map + , InsertWithAppend, UnionWithAppend + ) +import FIR.Definition + ( Definition(..) + , TriagedDefinitions + , TrieDefinitions + ) +import FIR.Prim.Array + ( Array, RuntimeArray ) +import FIR.Prim.Image + ( Image ) +import FIR.Prim.RayTracing + ( AccelerationStructure ) +import FIR.Prim.Struct + ( Struct ) +import FIR.Prim.Types + ( HasOpaqueType ) +import FIR.ProgramState + ( TLInterfaceVariable ) +import FIR.Validation.Images + ( ImageUsageFromProperties ) +import qualified SPIRV.Decoration as SPIRV + ( Decoration(..) ) +import qualified SPIRV.Image as SPIRV + ( ImageUsage ) +import qualified SPIRV.ExecutionMode as SPIRV + ( ExecutionMode ) +import qualified SPIRV.Stage as SPIRV + ( ExecutionModel, NamedExecutionModel ) +import qualified SPIRV.Image + ( ImageUsage(..) ) +import qualified SPIRV.Storage as SPIRV + ( StorageClass ) +import qualified SPIRV.Storage as Storage + ( StorageClass(..), RayStorage(ShaderRecordBuffer) ) + +------------------------------------------------------------------------ + +-- | Validate user-supplied top-level 'FIR.Definition.Definition's. +-- +-- Note that this only validates global variables and their layout, +-- as other kinds of validation are performed elsewhere. +-- See for instance 'FIR.Definition.StartState'. +type ValidDefinitions ( defs :: [ Symbol :-> Definition ] ) + = ( ValidTriagedDefinitions ( TrieDefinitions defs ) :: Constraint) + +-- | Validate that descriptor set and bindings don't overlap +type family NonOverlappingDescriptors ( globs :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] ) + :: Constraint + where + NonOverlappingDescriptors list = EnsureNoDuplicates (BuildDescriptorList list) + +type family BuildDescriptorList ( globs :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] ) :: Map (Nat, Nat) [Symbol] + where + BuildDescriptorList '[] = '[] + BuildDescriptorList ( (storage ':-> vars) ': globs ) = UnionWithAppend (GetDescriptor vars) (BuildDescriptorList globs) + +type family AppendMaybeDescriptor ( mbDescNo :: Maybe Nat ) ( mbBdNo :: Maybe Nat ) ( name :: Symbol ) ( bds :: Map (Nat,Nat) [Symbol] ) :: Map (Nat,Nat) [Symbol] where + AppendMaybeDescriptor ( Just descNo ) mbBdNo name bds = InsertWithAppend '( descNo, FromMaybe mbBdNo 0 ) name bds + -- Ignore bindings which don't have a "DescriptorSet" decoration. + AppendMaybeDescriptor _ _ _ bds = bds + +type family GetDescriptor ( globs :: [ Symbol :-> TLInterfaceVariable ] ) :: Map (Nat, Nat) [Symbol] + where + GetDescriptor '[] = '[] + GetDescriptor ( (k ':-> '( decs, ty )) ': globs ) = + AppendMaybeDescriptor ( ExtractDescriptorSet decs ) ( ExtractBinding decs ) k ( GetDescriptor globs ) + +type family ExtractDescriptorSet ( decs :: [ SPIRV.Decoration Nat ] ) :: Maybe Nat + where + ExtractDescriptorSet '[] = 'Nothing + ExtractDescriptorSet (SPIRV.DescriptorSet n ': globs) = 'Just n + ExtractDescriptorSet (_ ': globs) = ExtractDescriptorSet globs + +type family ExtractBinding ( decs :: [ SPIRV.Decoration Nat ] ) :: Maybe Nat + where + ExtractBinding '[] = 'Nothing + ExtractBinding (SPIRV.Binding n ': globs) = 'Just n + ExtractBinding (_ ': globs) = ExtractBinding globs + +type family EnsureNoDuplicates (as :: Map (Nat,Nat) [Symbol]) :: Constraint where + EnsureNoDuplicates '[] = () + EnsureNoDuplicates ( ( '( descNo, bdNo ) ':-> names ) ': bds ) = ( NoDuplicates descNo bdNo names, EnsureNoDuplicates bds ) + +type family NoDuplicates ( descNo :: Nat ) ( bdNo :: Nat ) ( names :: [Symbol] ) :: Constraint where + NoDuplicates _ _ '[] = () + NoDuplicates _ _ '[_] = () + NoDuplicates descNo bdNo names = TypeError + ( Text "More than one descriptor with DescriptorSet " :<>: ShowType descNo + :<>: Text " and Binding " :<>: ShowType bdNo :<>: Text ":" + :$$: ShowType names + ) + + +type family ValidTriagedDefinitions ( defs :: TriagedDefinitions ) :: Constraint where + ValidTriagedDefinitions '( _, eps, globs ) + = ( ValidGlobals globs, NonOverlappingDescriptors globs, NoDuplicateEntryPoints eps ) + -- * not validating functions: no validation necessary + -- * execution modes are validated as part of the computation of entry point info + +type family NoDuplicateEntryPoints + ( eps :: [ Symbol :-> ( SPIRV.ExecutionModel, [ SPIRV.ExecutionMode Nat ] ) ] ) + :: Constraint + where + NoDuplicateEntryPoints '[] = () + NoDuplicateEntryPoints ( ( k ':-> '( em, _ ) ) ': eps ) + = ( EntryPointNotDeclaredIn k em eps, NoDuplicateEntryPoints eps ) + +type family EntryPointNotDeclaredIn + ( k :: Symbol ) ( em :: SPIRV.ExecutionModel ) + ( eps :: [ Symbol :-> ( SPIRV.ExecutionModel, [ SPIRV.ExecutionMode Nat ] ) ] ) + :: Constraint + where + EntryPointNotDeclaredIn _ _ '[] = () + EntryPointNotDeclaredIn k em ( ( k ':-> '( em, _ ) ) ': _ ) + = TypeError + ( Text "Duplicate entry point declaration: " + :<>: Text ( SPIRV.NamedExecutionModel k em ) :<>: Text "." + ) + EntryPointNotDeclaredIn k em ( _ ': eps ) = EntryPointNotDeclaredIn k em eps + +type family ValidGlobals + ( globs :: [ SPIRV.StorageClass :-> [ Symbol :-> TLInterfaceVariable ] ] ) + :: Constraint + where + ValidGlobals '[] = () + ValidGlobals ( ( Storage.Input ':-> _ ) ': globs ) + -- no validity checking for input variables (see "FIR.Validation.Interface") + = ValidGlobals globs + ValidGlobals ( ( Storage.Output ':-> _ ) ': globs ) + -- no validity checking for output variables (see "FIR.Validation.Interface") + = ValidGlobals globs + ValidGlobals ( ( storage ':-> vars ) ': globs ) + = ( MapValidGlobal storage vars + , ValidGlobals globs + ) + + +type family MapValidGlobal + ( storage :: SPIRV.StorageClass ) + ( globals :: [ Symbol :-> TLInterfaceVariable ] ) + :: Constraint + where + MapValidGlobal _ '[] = () + MapValidGlobal storage ( ( k ':-> '( decs, ty ) ) ': globals ) + = ( ValidGlobal k storage decs ty + , MapValidGlobal storage globals + ) + +type family ValidGlobal + ( name :: Symbol ) + ( storage :: SPIRV.StorageClass ) + ( decs :: [ SPIRV.Decoration Nat ] ) + ( ty :: Type ) + :: Constraint + where + ValidGlobal name Storage.UniformConstant decs (Image props) + = ( ValidUniformDecorations + ( Text "Image named " :<>: ShowType name ) + decs + (Image props) + , ValidImageDecorations name (ImageUsageFromProperties props) decs + ) + ValidGlobal name Storage.UniformConstant decs AccelerationStructure + = ValidUniformDecorations + ( Text "Acceleration structure named " :<>: ShowType name ) + decs + AccelerationStructure + ValidGlobal name Storage.UniformConstant _ otherTy + = TypeError + ( Text "Uniform constant global named " :<>: ShowType name + :<>: Text " points to unexpected type " + :<>: ShowType otherTy :<>: Text "." + ) + ValidGlobal name Storage.Image decs (Image props) + = ( ValidUniformDecorations + ( Text "Storage image named " :<>: ShowType name ) + decs + (Image props) + , ValidImageDecorations name (ImageUsageFromProperties props) decs + ) + ValidGlobal name Storage.Image _ nonImageTy + = TypeError + ( Text "Image global named " :<>: ShowType name + :<>: Text " expected to point to an image, but points to " + :<>: ShowType nonImageTy :<>: Text " instead." + ) + ValidGlobal name Storage.Uniform decs (Struct as) + = ( ValidUniformDecorations + ( Text "Uniform buffer named " :<>: ShowType name ) + decs + (Struct as) + , NoOpaqueTypes name ( Text "buffer" ) as + ) + ValidGlobal name Storage.Uniform decs (Array n (Struct as)) + = ( ValidUniformDecorations + ( Text "Uniform buffer named " :<>: ShowType name ) + decs + (Array n (Struct as)) + , NoOpaqueTypes name ( Text "buffer" ) as + ) + ValidGlobal name Storage.Uniform _ ty + = TypeError + ( Text "Uniform buffer named " :<>: ShowType name + :<>: Text " should be backed by a struct or a fixed-size array containing a struct;" + :$$: Text "found type " :<>: ShowType ty :<>: Text " instead." + ) + ValidGlobal name Storage.StorageBuffer decs (Struct as) + = ( ValidUniformDecorations + ( Text "Uniform storage buffer named " :<>: ShowType name ) + decs + (Struct as) + , NoOpaqueTypesExceptRuntimeArrayLast name as + ) + ValidGlobal name Storage.StorageBuffer decs (Array n (Struct as)) + = ( ValidUniformDecorations + ( Text "Uniform storage buffer named " :<>: ShowType name ) + decs + (Array n (Struct as)) + , NoOpaqueTypes name ( Text "storage buffer" ) as + ) + ValidGlobal name Storage.StorageBuffer decs (RuntimeArray a) + = TypeError + ( Text "Uniform storage buffer named " :<>: ShowType name + :<>: Text " should be backed by a struct or a fixed-size array containing a struct;" + :$$: Text "found type " :<>: ShowType (RuntimeArray a) :<>: Text " instead." + :$$: Text "To use a dynamically sized array in a storage buffer, define a structure" + :<>: Text " whose last member is a RuntimeArray." + ) + ValidGlobal name Storage.StorageBuffer _ ty + = TypeError + ( Text "Uniform storage buffer named " :<>: ShowType name + :<>: Text " should be backed by a struct or fixed-size array containing a struct;" + :$$: Text "found type " :<>: ShowType ty :<>: Text " instead." + ) + ValidGlobal name Storage.PushConstant _ (Struct as) + = NoOpaqueTypes name ( Text "push constant" ) as + ValidGlobal name Storage.PushConstant _ ty + = TypeError + ( Text "Push constant named " :<>: ShowType name + :<>: Text " should be backed by a struct;" + :$$: Text "found type " :<>: ShowType ty :<>: Text " instead." + ) + ValidGlobal name ( 'Storage.RayStorage Storage.ShaderRecordBuffer ) _ (Struct as) + = NoOpaqueTypesExceptRuntimeArrayLast name as + ValidGlobal name ( 'Storage.RayStorage Storage.ShaderRecordBuffer ) _ ty + = TypeError + ( Text "Shader record buffer named " :<>: ShowType name + :<>: Text " should be backed by a struct;" + :$$: Text "found type " :<>: ShowType ty :<>: Text " instead." + ) + -- TODO: more validation for ray-tracing storage classes + ValidGlobal _ _ _ _ = () + +type family ValidUniformDecorations + ( name :: ErrorMessage ) + ( decs :: [ SPIRV.Decoration Nat ] ) + ( ty :: Type ) + :: Constraint + where + ValidUniformDecorations name decs _ + = ( HasBinding name decs, HasDescriptorSet name decs ) + +type family HasBinding + ( name :: ErrorMessage ) + ( decs :: [ SPIRV.Decoration Nat ] ) + :: Constraint + where + HasBinding _ ( SPIRV.Binding _ ': _ ) = () + HasBinding name ( _ ': decs ) = HasBinding name decs + HasBinding name '[] + = TypeError + ( name :<>: Text " is missing a 'Binding' decoration." ) + +type family HasDescriptorSet + ( name :: ErrorMessage ) + ( decs :: [ SPIRV.Decoration Nat ] ) + :: Constraint + where + HasDescriptorSet _ ( SPIRV.DescriptorSet _ ': _ ) = () + HasDescriptorSet name ( _ ': decs ) = HasDescriptorSet name decs + HasDescriptorSet name '[] + = TypeError + ( name :<>: Text " is missing a 'DescriptorSet' decoration." ) + +type family HasLocation + ( name :: Symbol ) + ( decs :: [ SPIRV.Decoration Nat ] ) + :: Constraint + where + HasLocation _ ( SPIRV.Location _ ': _ ) = () + HasLocation name ( _ ': decs ) = HasLocation name decs + HasLocation name '[] + = TypeError + ( ShowType name :<>: Text " is missing a 'Location' decoration." ) + +-- TODO: I'm not sure what the valid decorations are here... +type family ValidImageDecorations + ( name :: Symbol ) + ( imageTy :: SPIRV.ImageUsage ) + ( decs :: [ SPIRV.Decoration Nat] ) + :: Constraint + where + ValidImageDecorations _ _ '[] = () + ValidImageDecorations name ty ( SPIRV.DescriptorSet _ ': decs ) + = ValidImageDecorations name ty decs + ValidImageDecorations name ty ( SPIRV.Binding _ ': decs ) + = ValidImageDecorations name ty decs + ValidImageDecorations name ty ( SPIRV.NonReadable ': decs ) + = ValidImageDecorations name ty decs + ValidImageDecorations name SPIRV.Image.Storage ( SPIRV.NonWritable ': decs ) + = ValidImageDecorations name SPIRV.Image.Storage decs + ValidImageDecorations name _ ( dec ': _ ) + = TypeError + ( Text "Unexpected decoration " :<>: ShowType dec + :<>: Text " applied to image named " :<>: ShowType name + :<>: Text "." + ) + +type family NoOpaqueTypes + ( name :: Symbol ) + ( loc :: ErrorMessage ) + ( as :: [ Symbol :-> Type ] ) + :: Constraint + where + NoOpaqueTypes _ _ '[] = () + NoOpaqueTypes name loc ((k ':-> a) ': as) = + ( ErrorIfOpaque (HasOpaqueType a) name loc k a + , NoOpaqueTypes name loc as + ) + +type family ErrorIfOpaque (hasOpaque :: Bool) (name :: Symbol) (loc :: ErrorMessage) (k :: Symbol) (a :: Type) :: Constraint where + ErrorIfOpaque True name loc k a = + TypeError + ( Text "Structure member " :<>: ShowType k :<>: Text " cannot appear" + :<>: Text " in " :<>: loc :<>: Text " named " :<>: ShowType name :<>: Text "." + :$$: Text "Its type " :<>: ShowType a + :$$: Text "is opaque (or it contains an opaque type)." + ) + ErrorIfOpaque _ _ _ _ _ = () + +type family NoOpaqueTypesExceptRuntimeArrayLast ( name :: Symbol ) ( as :: [ Symbol :-> Type ] ) :: Constraint where + NoOpaqueTypesExceptRuntimeArrayLast _ '[] = () + NoOpaqueTypesExceptRuntimeArrayLast name ( ( k ':-> RuntimeArray a ) ': '[] ) = + ErrorIfOpaqueRuntimeArray (HasOpaqueType a) name k a + NoOpaqueTypesExceptRuntimeArrayLast name ( ( k ':-> RuntimeArray a ) ': _ ) = + TypeError + ( Text "Unexpected runtime array named " :<>: ShowType k + :<>: Text " within storage buffer named " :<>: Text name :<>: Text "." + :$$: Text "Runtime arrays must appear last in the structure." + ) + NoOpaqueTypesExceptRuntimeArrayLast name ( ( k ':-> a ) ': as ) = + ( NoOpaqueTypes name ( Text "storage buffer" ) '[ k ':-> a ] + , NoOpaqueTypesExceptRuntimeArrayLast name as + ) + +type family ErrorIfOpaqueRuntimeArray (hasOpaque :: Bool) (name :: Symbol) (k :: Symbol) (a :: Type) :: Constraint where + ErrorIfOpaqueRuntimeArray True name k a = + TypeError + ( Text "Structure member " :<>: ShowType k :<>: Text " cannot appear" + :<>: Text " in storage buffer named " :<>: ShowType name :<>: Text "." + :$$: Text "It is a runtime array whose element type" + :$$: ShowType a + :$$: Text "is opaque, or contains an opaque type." + ) + ErrorIfOpaqueRuntimeArray _ _ _ _ = () diff --git a/src/FIR/Validation/ExecutionModes.hs b/src/FIR/Validation/ExecutionModes.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/ExecutionModes.hs @@ -0,0 +1,416 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.Definitions + +Validate user-provided execution modes. + +For instance, this checks that compute shaders +are decorated with local group sizes, +or that a geometry shader specifies its output +primitive type. + +-} + +module FIR.Validation.ExecutionModes where + +-- base +import Data.Type.Bool + ( If, type (&&) ) +import GHC.TypeLits + ( Symbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.Error + ( Assert ) +import Data.Type.List + ( Elem ) +import Data.Type.Maybe + ( IsJust, FromMaybe ) +import SPIRV.ExecutionMode +import SPIRV.Stage + +-------------------------------------------------- +-- validation of execution modes (at the type level) + +type family ValidModelsFor (mode :: ExecutionMode Nat) :: [ ExecutionModel ] where + ValidModelsFor (Invocations _) = '[ Geometry ] + ValidModelsFor SpacingEqual = '[ TessellationControl, TessellationEvaluation ] + ValidModelsFor SpacingFractionalEven = '[ TessellationControl, TessellationEvaluation ] + ValidModelsFor SpacingFractionalOdd = '[ TessellationControl, TessellationEvaluation ] + ValidModelsFor VertexOrderCw = '[ TessellationControl, TessellationEvaluation ] + ValidModelsFor VertexOrderCcw = '[ TessellationControl, TessellationEvaluation ] + ValidModelsFor PixelCenterInteger = '[ Fragment ] + ValidModelsFor OriginUpperLeft = '[ Fragment ] + ValidModelsFor OriginLowerLeft = '[ Fragment ] + ValidModelsFor EarlyFragmentTests = '[ Fragment ] + ValidModelsFor PointMode = '[ TessellationControl, TessellationEvaluation ] + ValidModelsFor DepthReplacing = '[ Fragment ] + ValidModelsFor DepthGreater = '[ Fragment ] + ValidModelsFor DepthLess = '[ Fragment ] + ValidModelsFor DepthUnchanged = '[ Fragment ] + ValidModelsFor (LocalSize _ _ _) = '[ Compute, Kernel ] + ValidModelsFor (LocalSizeHint _ _ _) = '[ Kernel ] + ValidModelsFor InputPoints = '[ Geometry ] + ValidModelsFor InputLines = '[ Geometry ] + ValidModelsFor InputLinesAdjacency = '[ Geometry ] + ValidModelsFor Triangles = '[ Geometry, TessellationControl, TessellationEvaluation ] + ValidModelsFor InputTrianglesAdjacency = '[ Geometry ] + ValidModelsFor Quads = '[ TessellationControl, TessellationEvaluation ] + ValidModelsFor Isolines = '[ TessellationControl, TessellationEvaluation ] + ValidModelsFor (OutputVertices _) = '[ Geometry, TessellationControl, TessellationEvaluation ] + ValidModelsFor OutputPoints = '[ Geometry ] + ValidModelsFor OutputLineStrip = '[ Geometry ] + ValidModelsFor OutputTriangleStrip = '[ Geometry ] + ValidModelsFor (VecTypeHint _) = '[ Kernel ] + ValidModelsFor ContractionOff = '[ Kernel ] + ValidModelsFor (MaxPatchVertices _) = '[ TessellationControl ] + ValidModelsFor _ + -- for the moment, anything else is considered valid (no validity checks) + = '[ Vertex, TessellationControl, TessellationEvaluation, Geometry, Fragment, Compute, Kernel ] + + +type family ValidateExecutionModes + ( k :: Symbol ) + ( em :: ExecutionModel ) + ( modes :: [ExecutionMode Nat] ) + :: Maybe (ExecutionInfo Nat em) + where + ValidateExecutionModes k Fragment modes + = If ( HasValidOrigin k ( BackendOf Fragment ) modes + && HasAtMostOneOf k Fragment '[ DepthGreater, DepthLess, DepthUnchanged ] modes + && PertainTo k Fragment modes + ) + ( Just FragmentInfo ) + Nothing + ValidateExecutionModes k Vertex modes + = If ( PertainTo k Vertex modes ) + ( Just VertexInfo ) + Nothing + ValidateExecutionModes k TessellationControl modes + = If ( HasOneOf k TessellationControl '[ SpacingEqual, SpacingFractionalEven, SpacingFractionalOdd ] modes + && HasAtMostOneOf k TessellationControl '[ VertexOrderCw, VertexOrderCcw ] modes + && PertainTo k TessellationControl modes + ) + ( Just + ( TessellationControlInfo + ( TessellationControlMaxPatchVertices k modes ) + ( TessellationControlOutputSize k modes ) + ( TessellationControlMbMode k modes ) + ) + ) + Nothing + ValidateExecutionModes k TessellationEvaluation modes + = If ( HasAtMostOneOf k TessellationEvaluation '[ SpacingEqual, SpacingFractionalEven, SpacingFractionalOdd ] modes + && HasAtMostOneOf k TessellationEvaluation '[ VertexOrderCw, VertexOrderCcw ] modes + && PertainTo k TessellationEvaluation modes + ) + ( Just + ( TessellationEvaluationInfo + 32 -- default value + ( TessellationEvaluationMode k modes ) + ) + ) + Nothing + ValidateExecutionModes k Geometry modes + = If ( HasOneOf k Geometry '[ OutputPoints, OutputLineStrip, OutputTriangleStrip ] modes + && HasInvocations k modes + ) + ( Just + ( GeometryInputInfo k modes ) + ) + Nothing + ValidateExecutionModes k Compute modes + = If ( PertainTo k Compute modes ) + ( Just (ComputeInfo (LocalSizes k Compute modes) ) ) + Nothing + ValidateExecutionModes k Kernel modes + = If ( PertainTo k Kernel modes ) + ( Just (KernelInfo (LocalSizes k Kernel modes) ) ) + Nothing + ValidateExecutionModes k ( 'Stage ( 'RayStage rayShader ) ) modes + = If ( PertainTo k ( 'Stage ( 'RayStage rayShader ) ) modes ) + ( Just ( 'RayShaderInfo ( MkRayShaderInfo rayShader ) ) ) + Nothing + ValidateExecutionModes k em _ + = TypeError ( Text "Unsupported " :<>: Text (NamedExecutionModel k em) ) + +type family PertainTo (k :: Symbol) (em :: ExecutionModel) (modes :: [ExecutionMode Nat]) :: Bool where + PertainTo _ _ '[] = True + PertainTo k s (mode ': modes) + = Pertains k s mode (s `Elem` ValidModelsFor mode) && PertainTo k s modes + +type family Pertains (k :: Symbol) (em :: ExecutionModel) (mode :: m) (ok :: Bool) :: Bool where + Pertains _ _ _ True = True + Pertains k em mode False + = TypeError + ( Text (NamedExecutionModel k em) :<>: Text " does not support execution mode " + :<>: ShowType mode :<>: Text "." + ) + +-- | A fragment shader must specify its origin. +-- +-- Vulkan only allows 'OriginUpperLeft'. +type family HasValidOrigin (k :: Symbol) (backend :: Backend) (modes :: [ExecutionMode Nat]) :: Bool where + HasValidOrigin k Vulkan modes + = If ( OriginLowerLeft `Elem` modes ) + ( TypeError + ( Text (NamedExecutionModel k Fragment) :<>: Text " uses execution mode OriginLowerLeft, which Vulkan does not allow." + :$$: Text "Use OriginUpperLeft instead." + ) + ) + ( HasOneOf k Fragment '[ OriginUpperLeft ] modes ) + HasValidOrigin k _ modes + = HasOneOf k Fragment '[ OriginLowerLeft, OriginUpperLeft ] modes + +type family HasOneOf (k :: Symbol) (em :: ExecutionModel) (oneOf :: [ m ]) (modes :: [ m ]) :: Bool where + HasOneOf k em oneOf modes + = If ( IsJust ( LookupOneOf k em oneOf modes ) ) + True + ( TypeError + ( Text (NamedExecutionModel k em) :<>: Text " needs to be given one of the following execution modes:" + :$$: ShowType oneOf + ) + ) + +type family HasAtMostOneOf (k :: Symbol) (em :: ExecutionModel) (oneOf :: [ m ]) (modes :: [ m ]) :: Bool where + HasAtMostOneOf k em oneOf modes + = If ( IsJust ( LookupOneOf k em oneOf modes ) ) -- computes LookupOneOf which will error if there are conflicts + True + True + +type family LookupOneOf (k :: Symbol) (em :: ExecutionModel) (oneOf :: [ m ]) (modes :: [ m ]) :: Maybe m where + LookupOneOf k em oneOf '[] = Nothing + LookupOneOf k em oneOf (mode ': modes) + = If ( mode `Elem` oneOf ) + ( Just (NoConflictWithLookupOneOf k em mode ( LookupOneOf k em oneOf modes ) ) ) + ( LookupOneOf k em oneOf modes ) + +type family NoConflictWithLookupOneOf (k :: Symbol) (em :: ExecutionModel) (already :: m) (another :: Maybe m) :: m where + NoConflictWithLookupOneOf _ _ already Nothing = already + NoConflictWithLookupOneOf k em already (Just another) + = TypeError + ( Text (NamedExecutionModel k em) :<>: Text " has conflicting execution modes: " + :<>: ShowType already :<>: Text " and " :<>: ShowType another :<>: Text "." + ) + + +type family GeometryInputInfo + ( k :: Symbol ) + ( modes :: [ ExecutionMode Nat ] ) + :: (ExecutionInfo Nat Geometry) where + GeometryInputInfo k '[] + = TypeError + ( Text (NamedExecutionModel k Geometry) :<>: Text " is under-specified: missing input information." + :$$: Text "Must specify exactly one of 'Triangles', 'InputTrianglesAdjacency',\ + \ 'InputPoints', 'InputLines', 'InputLinesAdjacency'." + ) + GeometryInputInfo k ( InputPoints ': modes ) + = Assert ( NoSizes k Geometry InputPoints modes ) + ( GeometryInfo 1 InputModePoints ) + GeometryInputInfo k ( InputLines ': modes ) + = Assert ( NoSizes k Geometry InputLines modes ) + ( GeometryInfo 2 InputModeLines ) + GeometryInputInfo k ( InputLinesAdjacency ': modes ) + = Assert ( NoSizes k Geometry InputLinesAdjacency modes ) + ( GeometryInfo 4 InputModeLinesAdjacency ) + GeometryInputInfo k ( Triangles ': modes ) + = Assert ( NoSizes k Geometry Triangles modes ) + ( GeometryInfo 3 InputModeTriangles ) + GeometryInputInfo k ( InputTrianglesAdjacency ': modes ) + = Assert ( NoSizes k Geometry Triangles modes ) + ( GeometryInfo 6 InputModeTrianglesAdjacency ) + GeometryInputInfo k ( _ ': modes ) + = GeometryInputInfo k modes + +type family TessellationControlMbMode + ( k :: Symbol ) + ( modes :: [ ExecutionMode Nat ] ) + :: Maybe TessellationMode + where + TessellationControlMbMode k modes + = FmapReadTessellationMode + ( LookupOneOf k TessellationControl + '[ Triangles, Quads, Isolines, PointMode ] + modes + ) + +type family FmapReadTessellationMode + ( m :: Maybe (ExecutionMode Nat) ) + :: Maybe TessellationMode + where + FmapReadTessellationMode 'Nothing = 'Nothing + FmapReadTessellationMode ('Just mode) = 'Just (ReadTessellationMode mode) + +type family ReadTessellationMode (m :: ExecutionMode Nat) :: TessellationMode where + ReadTessellationMode Triangles = ModeTriangles + ReadTessellationMode Quads = ModeQuads + ReadTessellationMode Isolines = ModeIsolines + ReadTessellationMode PointMode = ModePoints + ReadTessellationMode nonMode + = TypeError + ( Text "Expected tessellation mode, but got " :<>: ShowType nonMode + :<>: Text " instead." + ) + + +type family TessellationEvaluationMode + ( k :: Symbol ) + ( modes :: [ ExecutionMode Nat ] ) + :: TessellationMode + where + TessellationEvaluationMode k modes + = ReadTessellationMode + ( FromMaybe + ( LookupOneOf k TessellationEvaluation + '[ Triangles, Quads, Isolines, PointMode ] + modes + ) + ( TypeError + ( Text (NamedExecutionModel k TessellationEvaluation) + :<>: Text " does not specify its tessellation mode." + :$$: Text "One of 'Triangles', 'Quads', 'Isolines' or 'PointMode' must be provided." + ) + ) + ) + +type family TessellationControlOutputSize + ( k :: Symbol ) + ( modes :: [ ExecutionMode Nat ] ) + :: Nat + where + TessellationControlOutputSize k '[] + = TypeError + ( Text (NamedExecutionModel k TessellationControl) :<>: Text " is under-specified: missing number of output points." + :$$: Text "The 'OutputVertices' execution mode must be provided." + ) + TessellationControlOutputSize k ( OutputVertices verts ': modes ) + = Assert ( NoOutputVertices k TessellationControl verts modes ) + verts + TessellationControlOutputSize k (_ ': modes ) + = TessellationControlOutputSize k modes + +type family TessellationControlMaxPatchVertices ( k :: Symbol ) ( modes :: [ ExecutionMode Nat ] ) :: Nat where + TessellationControlMaxPatchVertices k '[] = 32 -- default as used by SPIR-V + TessellationControlMaxPatchVertices k ( MaxPatchVertices verts ': _ ) + = verts + TessellationControlMaxPatchVertices k (_ ': modes) + = TessellationControlMaxPatchVertices k modes + +type family NoSizes + ( k :: Symbol ) + ( em :: ExecutionModel ) + ( givenSize :: ExecutionMode Nat ) + ( modes :: [ ExecutionMode Nat ] ) + :: Bool + where + NoSizes _ _ _ '[] + = 'True + NoSizes k em given (InputPoints ': _ ) + = TypeError + ( Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs." + :$$: Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType (InputPoints :: ExecutionMode Nat ) :<>: Text "." + ) + NoSizes k em given (InputLines ': _ ) + = TypeError + ( Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs." + :$$: Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType (InputLines :: ExecutionMode Nat ) :<>: Text "." + ) + NoSizes k em given (InputLinesAdjacency ': _ ) + = TypeError + ( Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs." + :$$: Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType ( InputLinesAdjacency :: ExecutionMode Nat ) :<>: Text "." + ) + NoSizes k em given (Triangles ': _ ) + = TypeError + ( Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs." + :$$: Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType ( Triangles :: ExecutionMode Nat ) :<>: Text "." + ) + NoSizes k em given (InputTrianglesAdjacency ': _ ) + = TypeError + ( Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs." + :$$: Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType ( InputTrianglesAdjacency :: ExecutionMode Nat ) :<>: Text "." + ) + NoSizes k em given (Quads ': _ ) + = TypeError + ( Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs." + :$$: Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType ( Quads :: ExecutionMode Nat ) :<>: Text "." + ) + NoSizes k em given (Isolines ': _ ) + = TypeError + ( Text (NamedExecutionModel k em) :<>: Text " has conflicting inputs." + :$$: Text "Provided both " :<>: ShowType given :<>: Text " and " :<>: ShowType ( Isolines :: ExecutionMode Nat ) :<>: Text "." + ) + NoSizes k em given ( _ ': modes ) + = NoSizes k em given modes + +type family NoOutputVertices + ( k :: Symbol ) + ( em :: ExecutionModel ) + ( givenVerts :: Nat ) + ( modes :: [ ExecutionMode Nat ] ) + :: Bool + where + NoOutputVertices _ _ _ '[] = True + NoOutputVertices k em givenVerts ( OutputVertices verts ': _ ) + = TypeError + ( Text (NamedExecutionModel k em) :<>: Text "has conflicting numbers of output vertices." + :$$: Text "Provided both " :<>: ShowType givenVerts :<>: Text " and " :<>: ShowType verts :<>: Text "." + ) + NoOutputVertices k em given ( _ ': modes ) + = NoOutputVertices k em given modes + +type family LocalSizes + ( k :: Symbol ) + ( em :: ExecutionModel ) + ( modes :: [ ExecutionMode Nat ] ) + :: (Nat, Nat, Nat) + where + LocalSizes k em '[] + = TypeError + ( Text (NamedExecutionModel k em) :<>: Text " is missing 'LocalSize' information." ) + LocalSizes k em ( LocalSize x y z ': modes ) + = Assert ( NoLocalSizes k em '(x,y,z) modes ) + ( '(x,y,z) ) + LocalSizes k em ( _ ': modes ) = LocalSizes k em modes + +type family NoLocalSizes + ( k :: Symbol ) + ( em :: ExecutionModel ) + ( xyz :: (Nat,Nat,Nat) ) + ( modes :: [ ExecutionMode Nat ] ) + :: Bool + where + NoLocalSizes _ _ _ '[] = 'True + NoLocalSizes k em xyz (LocalSize x' y' z' ': _) + = TypeError + ( Text (NamedExecutionModel k em) :<>: Text " has conflicting local size information." + :$$: Text "Provided both " :<>: ShowType xyz + :<>: Text " and " :<>: ShowType '(x',y',z') :<>: Text "." + ) + NoLocalSizes k em xyz ( _ ': modes ) + = NoLocalSizes k em xyz modes + +type family HasInvocations + ( k :: Symbol ) + ( modes :: [ ExecutionMode Nat ] ) + :: Bool + where + HasInvocations k '[] + = TypeError + ( Text (NamedExecutionModel k Geometry) :<>: Text " is missing the number of invocations." + :$$: Text "Expecting an 'Invocations i' execution mode, with 0 < i <= maxGeometryShaderInvocations." + ) + HasInvocations k ( Invocations 0 ': _ ) + = TypeError + ( Text (NamedExecutionModel k Geometry) :<>: Text ": number of invocations cannot be 0." ) + HasInvocations k ( Invocations _ ': _ ) = True + HasInvocations k ( _ ': modes ) = HasInvocations k modes diff --git a/src/FIR/Validation/Formats.hs b/src/FIR/Validation/Formats.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/Formats.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.Formats + +Computes the image formats underlying a given layout. + +-} + +module FIR.Validation.Formats + ( ComputeFormats ) + where + +-- base +import Data.Kind + ( Type ) +import Data.Type.Bool + ( If, type (&&), type (||) ) +import Data.Type.Equality + ( type (==) ) +import GHC.TypeNats + ( Nat + , type (+), type (-), Div + ) + +-- fir +import Data.Type.List + ( Length, Replicate, type (:++:) ) +import Data.Type.Map + ( Map, (:->)((:->)) ) +import Data.Type.POrd + ( POrd(..) ) +import FIR.Prim.Array + ( Array ) +import FIR.Prim.Struct + ( LocationSlot(LocationSlot) ) +import FIR.Prim.Types + ( SKPrimTy(..), SKPrimTyMap(..) + , PrimTySing + , ScalarFromSScalar + ) +import Math.Linear + ( V, M ) +import qualified SPIRV.Image +import qualified SPIRV.Image as SPIRV + ( ImageFormat(ImageFormat) ) +import qualified SPIRV.ScalarTy as SPIRV + +-------------------------------------------------------------------------- +-- computing image formats for vertex input backed by a structure type + +type family ComputeFormats + ( slots :: Map (LocationSlot Nat) Type ) + :: Map Nat ( SPIRV.ImageFormat Nat ) + where + ComputeFormats '[] = '[] + ComputeFormats ( (loc ':-> ty) ': slots ) + = InsertFormatsCombining + ( ComputeSlotFormats loc (PrimTySing ty) ) + ( ComputeFormats slots ) + +-------------------------------------------------------------------------- +-- computing image formats for a given type + +type family ComputeSlotFormats + ( loc :: LocationSlot Nat ) + ( skTy :: SKPrimTy ty ) + :: [ Nat :-> SPIRV.ImageFormat Nat ] + where + -- scalars + ComputeSlotFormats ('LocationSlot l c) ( SKScalar s :: SKPrimTy ty ) + = '[ l ':-> ScalarFormat ('LocationSlot l c) 1 ( ScalarFromSScalar s ) ] + -- vectors + ComputeSlotFormats ('LocationSlot l c) ( SKVector s :: SKPrimTy (V m ty) ) + = '[ l ':-> ScalarFormat ('LocationSlot l c) m ( ScalarFromSScalar s ) ] + -- matrices + ComputeSlotFormats ('LocationSlot l c) ( SKMatrix s :: SKPrimTy (M m n ty) ) + = MatrixSlotFormats l m + ( ComponentOf ( ScalarFromSScalar s ) ) + ( SPIRV.WidthToNat (SPIRV.ScalarWidth ( ScalarFromSScalar s ) ) ) + -- arrays + ComputeSlotFormats ('LocationSlot l c) ( SKArray elt :: SKPrimTy (Array 0 ty) ) + = '[ ] + ComputeSlotFormats ('LocationSlot l c) ( SKArray elt :: SKPrimTy (Array 1 ty) ) + = ComputeSlotFormats ('LocationSlot l c) ( elt :: SKPrimTy ty ) + ComputeSlotFormats ('LocationSlot l c) ( SKArray elt :: SKPrimTy (Array n ty) ) + = CompoundSlotFormats + ( 'LocationSlot l c ) + ( ComputeSlotFormats ('LocationSlot l c) elt ) + ( SKArray elt :: SKPrimTy (Array (n-1) ty) ) + -- structs + ComputeSlotFormats ('LocationSlot l c) ( SKStruct SKNil ) = '[] + ComputeSlotFormats ('LocationSlot l c) ( SKStruct (elt `SKCons` elts) ) + = CompoundSlotFormats + ( 'LocationSlot l c ) + ( ComputeSlotFormats ('LocationSlot l c) elt ) + ( SKStruct elts ) + -- unsupported types: unit, bool, runtime array + ComputeSlotFormats _ SKUnit = '[] + ComputeSlotFormats _ SKBool = '[] + ComputeSlotFormats _ (SKRuntimeArray _ ) = '[] + +type family ScalarFormat + ( loc :: LocationSlot Nat ) + ( elems :: Nat ) + ( scalarTy :: SPIRV.ScalarTy ) + :: SPIRV.ImageFormat Nat + where + ScalarFormat loc elems scalarTy + = FormatForComponentsOfWidth + loc elems + ( ComponentOf scalarTy ) + ( SPIRV.WidthToNat (SPIRV.ScalarWidth scalarTy ) ) + +type family MatrixSlotFormats + ( loc :: Nat ) + ( n :: Nat ) + ( comp :: SPIRV.Image.Component ) + ( width :: Nat ) + :: [ Nat :-> SPIRV.ImageFormat Nat ] + where + MatrixSlotFormats _ 0 _ _ = '[] + MatrixSlotFormats l 1 comp w = '[ l ':-> 'SPIRV.ImageFormat comp ( Replicate 4 w ) ] + MatrixSlotFormats l n comp w + = ( l ':-> 'SPIRV.ImageFormat comp ( Replicate 4 w ) ) + ': MatrixSlotFormats ( l + ( w `Div` 32 ) ) ( n-1 ) comp w + +type family CompoundSlotFormats + ( loc :: LocationSlot Nat ) + ( fmts :: [ Nat :-> SPIRV.ImageFormat Nat ] ) + ( skTy :: SKPrimTy ty ) + :: [ Nat :-> SPIRV.ImageFormat Nat ] + where + CompoundSlotFormats ('LocationSlot l c) fmts skTy + = fmts + :++: + ComputeSlotFormats ('LocationSlot (NextAvailableLocation l fmts) c) skTy + +type family NextAvailableLocation + ( loc :: Nat ) + ( fmts :: [ Nat :-> SPIRV.ImageFormat Nat ] ) + :: Nat + where + NextAvailableLocation l '[] + = l + NextAvailableLocation _ ( (l ':-> _) ': ls ) + = NextAvailableLocation (l + 1) ls + +type family FormatForComponentsOfWidth + ( loc :: LocationSlot Nat ) + ( elems :: Nat ) + ( component :: SPIRV.Image.Component ) + ( width :: Nat ) + :: ( SPIRV.ImageFormat Nat ) where + FormatForComponentsOfWidth ('LocationSlot _ c) elems comp w + = 'SPIRV.ImageFormat comp ( Replicate ( elems + ( c `Div` ( Max w 32 `Div` 32 ) ) ) w ) + +type family ComponentOf (scalar :: SPIRV.ScalarTy) :: SPIRV.Image.Component where + ComponentOf (SPIRV.Integer SPIRV.Unsigned _) = SPIRV.Image.UI + ComponentOf (SPIRV.Integer SPIRV.Signed _) = SPIRV.Image.I + ComponentOf (SPIRV.Floating _ ) = SPIRV.Image.F + +-------------------------------------------------------------------------- +-- combining formats + +type family InsertFormatsCombining + ( fmts :: [ Nat :-> SPIRV.ImageFormat Nat ] ) + ( nxt :: Map Nat ( SPIRV.ImageFormat Nat ) ) + :: Map Nat ( SPIRV.ImageFormat Nat ) + where + InsertFormatsCombining '[] nxt = nxt + InsertFormatsCombining ( fmt ': fmts ) nxt + = InsertFormatCombining fmt ( InsertFormatsCombining fmts nxt ) + +type family InsertFormatCombining + ( fmt :: ( Nat :-> SPIRV.ImageFormat Nat ) ) + ( fmts :: Map Nat ( SPIRV.ImageFormat Nat ) ) + :: Map Nat ( SPIRV.ImageFormat Nat ) + where + InsertFormatCombining fmt '[] + = '[ fmt ] + InsertFormatCombining ( i ':-> fmt1 ) ( ( i ':-> fmt2 ) ': fmts ) + = ( i ':-> LargestFormat fmt1 fmt2 ) ': fmts + InsertFormatCombining ( i1 ':-> fmt1 ) ( ( i2 ':-> fmt2 ) ': fmts ) + = MaybeInsertCombination i1 fmt1 i2 fmt2 + (Combination i1 fmt2 i2 fmt2) + fmts + +type family MaybeInsertCombination + ( i1 :: Nat ) + ( fmt1 :: SPIRV.ImageFormat Nat ) + ( i2 :: Nat ) + ( fmt2 :: SPIRV.ImageFormat Nat ) + ( comb :: Maybe ( Nat, SPIRV.ImageFormat Nat) ) + ( fmts :: Map Nat ( SPIRV.ImageFormat Nat ) ) + :: Map Nat ( SPIRV.ImageFormat Nat ) + where + MaybeInsertCombination _ _ _ _ ( Just '(i, fmt) ) fmts + = ( ( i ':-> fmt ) ': fmts ) + MaybeInsertCombination i1 fmt1 i2 fmt2 'Nothing fmts + = If ( i1 :< i2 ) + ( ( i1 ':-> fmt1 ) ': ( i2 ':-> fmt2 ) ': fmts ) + ( ( i2 ':-> fmt2 ) ': InsertFormatCombining ( i1 ':-> fmt1 ) fmts ) + +type family Combination + ( i1 :: Nat ) + ( fmt1 :: SPIRV.ImageFormat Nat ) + ( j2 :: Nat ) + ( fmt2 :: SPIRV.ImageFormat Nat ) + :: Maybe ( Nat, SPIRV.ImageFormat Nat ) + where + Combination i fmt1 i fmt2 + = Just '( i, LargestFormat fmt1 fmt2 ) + Combination i1 ( 'SPIRV.ImageFormat comp widths1 ) i2 ( 'SPIRV.ImageFormat _ widths2 ) + = CrossLocationCombine comp i1 widths1 (Length widths2) i2 widths2 (Length widths2) + +type family CrossLocationCombine + ( comp :: SPIRV.Image.Component ) + ( i1 :: Nat ) + ( widths1 :: [Nat] ) + ( lg1 :: Nat ) + ( i2 :: Nat ) + ( widths2 :: [Nat] ) + ( lg2 :: Nat ) + :: Maybe ( Nat, SPIRV.ImageFormat Nat ) + where + CrossLocationCombine comp i1 widths1 lg1 i2 widths2 lg2 + = If ( ( i2 == i1 + 1 && ComponentsUsed widths1 :> 4 && Length widths2 :<= 2 ) + || ( i1 == i2 + 1 && ComponentsUsed widths2 :> 4 && Length widths1 :<= 2 ) + ) + ( Just + '( Min i1 i2 + , 'SPIRV.ImageFormat comp + ( Replicate + ( Max lg1 ( Max lg2 ( Min lg1 lg2 + 1 ) ) ) -- sorry + 64 + ) + ) + ) + Nothing + +type family ComponentsUsed ( widths :: [Nat] ) :: Nat where + ComponentsUsed '[] = 0 + ComponentsUsed (w ': ws) = ( w `Div` 32 ) + ComponentsUsed ws + +type family LargestFormat + ( fmt1 :: SPIRV.ImageFormat Nat ) + ( fmt2 :: SPIRV.ImageFormat Nat ) + :: SPIRV.ImageFormat Nat + where + LargestFormat ( 'SPIRV.ImageFormat comp1 widths1 ) ( 'SPIRV.ImageFormat comp2 widths2 ) + = If ( Length widths2 :> Length widths1 ) + ( 'SPIRV.ImageFormat comp2 widths2 ) + ( 'SPIRV.ImageFormat comp1 widths1 ) + -- simply picking the largest of the two formats + -- + -- trying to not throw any errors even when results don't make sense, + -- as layout validation should prevent anything silly from happening + -- (and we don't want to duplicate error messages) diff --git a/src/FIR/Validation/Images.hs b/src/FIR/Validation/Images.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/Images.hs @@ -0,0 +1,656 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.Images + +Validation module for stateful operations involving images, +such as 'FIR.Syntax.Program.imageRead', 'FIR.Syntax.Program.imageWrite', +using type families with custom type errors. + +This checks, for instance, that one doesn't access a non-sampled storage image +using floating-point texel coordinates. + +-} + +module FIR.Validation.Images + ( LookupImageProperties + , ImageUsageFromProperties + , ValidImageRead, ValidImageWrite + , ValidImageCoordinate, ValidImageGradCoordinate, ValidImageOffsetCoordinate + , ImageTexelType + , MatchesFormat, BasicDim, NotCubeDim + , CanAddProj, CanAddDref + , UsesAffineCoords + , NoDuplicate + , NoMS, CanMultiSample + , NoLODOps, SupportsDepthTest + , ValidQueryImageSize, ValidQueryImageSizeLOD + , ValidQueryImageLOD, ValidQueryImageLevels, ValidQueryImageSamples + ) + where + +-- base +import Data.Kind + ( Type, Constraint ) +import Data.Type.Bool + ( If, type (&&), Not ) +import Data.Type.Equality + ( type (==) ) +import GHC.TypeLits + ( Symbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.List + ( Elem ) +import Data.Type.Map + ( Lookup ) +import FIR.Binding + ( Binding, BindingsMap, Var ) +import {-# SOURCE #-} FIR.Prim.Image + ( ImageProperties(Properties), Image + , OperandName(DepthComparison, ProjectiveCoords, BaseOperand) + , ImageCoordinateKind(..) + ) +import FIR.Prim.Types + ( ScalarFromTy ) +import FIR.ProgramState + ( ProgramState(ProgramState) ) +import Math.Linear + ( V ) +import SPIRV.Image + ( ImageUsage(Sampled, Storage) + , ImageFormat(ImageFormat), I, UI + , ImageFormatDimension + , RequiredFormatUsage + , Arrayness(..) + , Dimensionality(..) + , Normalisation(..) + , HasDepth(..) + , MultiSampling(..) + , Operand(..) + , Projection(..) + ) +import qualified SPIRV.Image as Image + ( Component(Integer, Floating) + , Operand(..) + ) +import qualified SPIRV.Image as LOD + ( LODOperand ) +import qualified SPIRV.ScalarTy as SPIRV + ( ScalarTy(Integer, Floating) ) + +------------------------------------------------- +-- * Constraints for images. + +-- | Retrieve the properties of an image. +-- +-- Throws a type error if there is no image with given name. +type family LookupImageProperties (k :: Symbol) (i :: ProgramState) :: ImageProperties where + LookupImageProperties k ('ProgramState i _ _ _ _ _ _ _) + = ImagePropertiesFromLookup k i (Lookup k i) + +type family ImagePropertiesFromLookup + ( k :: Symbol ) + ( i :: BindingsMap ) + ( lookup :: Maybe Binding ) + :: ImageProperties + where + ImagePropertiesFromLookup _ _ (Just (Var _ (Image props))) = props + ImagePropertiesFromLookup k i Nothing + = TypeError ( Text "Expected an image, \ + \but nothing is bound by name " :<>: ShowType k + ) + ImagePropertiesFromLookup k i (Just nonImage) + = TypeError ( Text "Unexpected type " :<>: ShowType nonImage + :<>: Text " bound by name " :<>: ShowType k + :$$: Text "Expected an image." + ) + +type family ImageUsageFromProperties ( props :: ImageProperties ) :: ImageUsage where + ImageUsageFromProperties ( Properties _ _ _ _ _ _ usage _ ) = usage + +-- | Check that we can read from an image. +-- +-- Depending on the coordinate type, this is either a sampling operation +-- or a direct image read operation. +-- +-- Throws a type error if the operation is incompatible with the given +-- image properties. For instance, if the image is a depth image, +-- a depth-comparison reference value must be provided. +-- +-- Refer to the @SPIR-V@ specification for what operations are allowed. +type family ValidImageRead + ( props :: ImageProperties ) + ( ops :: [OperandName] ) + ( coordType :: Type ) + :: Constraint where + ValidImageRead + ( Properties coordKind res dim depth arr ms usage fmt ) + ops + coordType + = ( AllowedIndexing coordKind ms usage + , CheckDepthTest (DepthComparison `Elem` ops) coordKind depth + , CheckLODOperands coordKind ops + , CompatibleFormat (ScalarFromTy res) usage fmt + , ValidCoordinateType "image coordinates (for reading)" (ImageCoordinatesDim dim arr ops) coordKind coordType + ) + +type family ValidImageCoordinate + ( props :: ImageProperties ) + ( ops :: [ OperandName ] ) + ( coordType :: Type ) + where + ValidImageCoordinate ( Properties coordKind _ _ _ _ _ _ _ ) _ coordType + = ValidCoordinateType "image coordinates" 1 coordKind coordType + +type family ValidImageGradCoordinate + ( props :: ImageProperties ) + ( ops :: [ OperandName ] ) + ( coordType :: Type ) + where + ValidImageGradCoordinate ( Properties coordKind _ dim _ _ _ _ _ ) ops coordType + = ValidCoordinateType "gradient coordinates" (GradCoordinatesDim dim ops) coordKind coordType + +type family ValidImageOffsetCoordinate + ( props :: ImageProperties ) + ( ops :: [ OperandName ] ) + ( coordType :: Type ) + where + ValidImageOffsetCoordinate ( Properties coordKind _ dim _ _ _ _ _ ) ops coordType + = ValidCoordinateType "offset coordinates" (OffsetCoordinatesDim dim ops) coordKind coordType + +type family ValidCoordinateType + ( coordsName :: Symbol ) + ( coordDim :: Nat ) + ( coordKind :: ImageCoordinateKind ) + ( coordType :: Type ) + :: Constraint where + ValidCoordinateType _ 1 coordKind a = CoordinateConstraint coordKind a + ValidCoordinateType _ n coordKind ( V n a ) = CoordinateConstraint coordKind a + ValidCoordinateType coordsName n coordKind ( V j a ) = + TypeError + ( Text "Use of " :<>: Text coordsName :<>: Text " of the wrong dimension." + :$$: Text "Expected dimension: " :<>: ShowType n + :$$: Text " Actual dimension: " :<>: ShowType j + ) + ValidCoordinateType coordsName n IntegralCoordinates nonVec = + TypeError + ( Text "Cannot use type " :<>: ShowType nonVec :<>: Text " as " :<>: Text coordsName :<>: Text "." + :$$: Text "Expected a vector of integral types of dimension " :<>: ShowType n :<>: Text "." + ) + ValidCoordinateType coordsName n FloatingPointCoordinates nonVec = + TypeError + ( Text "Cannot use type " :<>: ShowType nonVec :<>: Text " as " :<>: Text coordsName :<>: Text "." + :$$: Text "Expected a vector of floating-point types of dimension " :<>: ShowType n :<>: Text "." + ) + + +type family CoordinateConstraint ( coordKind :: ImageCoordinateKind ) :: ( Type -> Constraint ) where + CoordinateConstraint IntegralCoordinates = Integral + CoordinateConstraint FloatingPointCoordinates = Floating + +-- | Check that we can write to an image. +-- +-- Throws a type error if: +-- +-- * the image is not a storage image, +-- * the image is a depth image, +-- * the coordinate type is not an integral type, or is of the wrong dimension, +-- * an operand is incompatible with the given image properties, +-- * an operand doesn't make sense for write operations. +-- +-- Refer to the @SPIR-V@ specification for what operations are allowed. +type family ValidImageWrite + ( props :: ImageProperties ) + ( ops :: [OperandName] ) + ( coordType :: Type ) + :: Constraint where + ValidImageWrite + ( Properties _ _ _ _ _ _ Sampled _ ) + ops + _ + = TypeError ( Text "Cannot write to a sampled image; must be a storage image." ) + ValidImageWrite + ( Properties _ _ _ (Just DepthImage) _ _ _ _ ) + ops + _ + = TypeError ( Text "Cannot write to a depth image." ) + ValidImageWrite + ( Properties coordKind res dim _ arr _ usage fmt ) + ops + coordType + = ( IntegralIndexing coordKind + , CompatibleFormat (ScalarFromTy res) usage fmt + , AllowedWriteOps ops + , ValidCoordinateType "image coordinates (for writing)" (ImageCoordinatesDim dim arr ops) coordKind coordType + ) + +type family IntegralIndexing (inty :: ImageCoordinateKind) :: Constraint where + IntegralIndexing FloatingPointCoordinates + = TypeError ( Text "Cannot write to an image using floating-point coordinates." ) + IntegralIndexing _ = () + +-- Check whether floating-point coordinates are allowed. +type family AllowedIndexing + ( inty :: ImageCoordinateKind ) + ( ms :: MultiSampling ) + ( usage :: ImageUsage ) + :: Constraint where + AllowedIndexing FloatingPointCoordinates _ Storage + = TypeError + ( Text "Cannot use floating-point coordinates with a storage image." ) + AllowedIndexing FloatingPointCoordinates MultiSampled _ + = TypeError + ( Text "Cannot use floating-point coordinates with multi-sampling." ) + AllowedIndexing _ _ _ = () + +-- Check that depth-testing is appropriately performed. +type family CheckDepthTest + ( depthTesting :: Bool ) + ( inty :: ImageCoordinateKind ) + ( depth :: Maybe HasDepth ) + :: Constraint where + CheckDepthTest False _ (Just DepthImage) + = TypeError + ( Text "Must use a depth comparison with this depth image." ) + CheckDepthTest True _ (Just NotDepthImage) + = TypeError + ( Text "Cannot perform depth comparison: not a depth image." ) + CheckDepthTest True IntegralCoordinates _ + = TypeError + ( Text "Cannot perform depth comparison using integral coordinates." ) + CheckDepthTest _ _ _ = () + +-- If using integral coordinates, LOD instructions cannot be provided. +type family CheckLODOperands + ( inty :: ImageCoordinateKind ) + ( ops :: [OperandName] ) + :: Constraint where + CheckLODOperands FloatingPointCoordinates _ = () + CheckLODOperands _ ( BaseOperand ('LODOperand lod) ': _ ) + = TypeError + ( ShowType lod :<>: Text " operand not allowed: using integral coordinates." ) + CheckLODOperands inty ( op ': ops ) = CheckLODOperands inty ops + CheckLODOperands _ '[] = () + +type family CompatibleFormat + ( inty :: SPIRV.ScalarTy ) + ( usage :: ImageUsage ) + ( fmt :: Maybe (ImageFormat Nat) ) + :: Constraint + where + CompatibleFormat (SPIRV.Integer _ _) _ (Just ('ImageFormat (Image.Integer Normalised _) _)) + = TypeError + ( Text "Expected a floating-point type, but provided an integer type." + :$$: Text "Image uses a normalised integer format, resulting in floating-point texel data." + ) + CompatibleFormat (SPIRV.Integer _ _) _ (Just ('ImageFormat Image.Floating _)) + = TypeError + ( Text "Expected a floating-point type, but provided an integer type." + :$$: Text "Image uses a floating-point format." + ) + CompatibleFormat (SPIRV.Floating _) _ (Just ('ImageFormat (Image.Integer Unnormalised _) _)) + = TypeError + ( Text "Expected an integral type, but provided a floating-point type." + :$$: Text "Image uses unnormalised integers, resulting in integral texel data." + ) + CompatibleFormat _ Storage _ + = () + CompatibleFormat _ Sampled (Just fmt) + = If + ( RequiredFormatUsage fmt == Just Storage ) + ( TypeError + ( Text "Image format " :<>: ShowType fmt + :<>: Text " can only be used with storage images." + ) + ) + ( () :: Constraint ) + +-- Only 'Sample' and 'Offset'/'ConstOffset' image operands allowed. +type family AllowedWriteOps (ops :: [OperandName]) :: Constraint where + AllowedWriteOps '[] = () + AllowedWriteOps (BaseOperand Image.Sample ': ops) = AllowedWriteOps ops + AllowedWriteOps (BaseOperand Image.ConstOffset ': ops) = AllowedWriteOps ops + AllowedWriteOps (BaseOperand Image.Offset ': ops) = AllowedWriteOps ops + AllowedWriteOps (op ': _ ) + = TypeError ( Text "Image operand " :<>: ShowType op + :<>: Text " cannot be used in conjunction \ + \with an image write operation." + ) + + + +---------------------------------------------------------- +-- Computing relevant image coordinate type. + +-- | Dimension of the coordinates used by an image. +-- +-- For instance, a simple 2D texture requires a dimension 2 vector, +-- simple 3D textures and cube maps requires a dimension 3 vector, etc. +type family ImageCoordinatesDim + ( dim :: Dimensionality ) + ( arr :: Arrayness ) + ( ops :: [OperandName] ) + :: Nat where + ImageCoordinatesDim dim arr ops = + If ( ProjectiveCoords `Elem` ops ) + ( ComputeCoordsDim dim arr Projective ) + ( ComputeCoordsDim dim arr Affine ) + +-- | Texel type of an image. +-- +-- This is what is returned from an image sampling operation, +-- or needs to be provided for an image write operation. +type family ImageTexelType + ( props :: ImageProperties ) + ( ops :: [OperandName] ) + :: Type + where + ImageTexelType ( Properties _ r _ _ _ _ _ fmt ) ops + = If + ( DepthComparison `Elem` ops + && Not ( (BaseOperand ConstOffsets) `Elem` ops) + ) + r + ( MkTexelType fmt r ) + +type family MkTexelType ( fmt :: Maybe ( ImageFormat Nat ) ) ( texel :: Type ) :: Type where + MkTexelType Nothing texel = V 4 texel -- most flexible default type for unknown image format + MkTexelType ( Just fmt ) texel = MkTexelType' ( ImageFormatDimension fmt ) texel + +type family MkTexelType' ( dim :: Nat ) ( texel :: Type ) :: Type where + MkTexelType' 1 texel = texel + MkTexelType' n texel = V n texel + +type family ComputeCoordsDim + ( dim :: Dimensionality ) + ( arr :: Arrayness ) + ( proj :: Projection ) + :: Nat + where + ComputeCoordsDim OneD NonArrayed Affine = 1 + ComputeCoordsDim TwoD NonArrayed Affine = 2 + ComputeCoordsDim ThreeD NonArrayed Affine = 3 + ComputeCoordsDim Cube NonArrayed Affine = 3 + ComputeCoordsDim Rect NonArrayed Affine = 2 + ComputeCoordsDim Buffer NonArrayed Affine = 1 + ComputeCoordsDim SubpassData NonArrayed Affine = 2 + ComputeCoordsDim OneD NonArrayed Projective = 2 + ComputeCoordsDim TwoD NonArrayed Projective = 3 + ComputeCoordsDim ThreeD NonArrayed Projective = 4 + ComputeCoordsDim Cube NonArrayed Projective = 4 + ComputeCoordsDim Rect NonArrayed Projective = 3 + ComputeCoordsDim Buffer NonArrayed Projective = 2 + ComputeCoordsDim SubpassData NonArrayed Projective = 3 + ComputeCoordsDim OneD Arrayed Affine = 2 + ComputeCoordsDim TwoD Arrayed Affine = 3 + ComputeCoordsDim Cube Arrayed Affine = 3 -- weird stuff going on here + ComputeCoordsDim dim Arrayed Affine + = TypeError ( Text "Unsupported arrayed image format \ + \with dimensionality " + :<>: ShowType dim + ) + ComputeCoordsDim dim Arrayed Projective + = TypeError ( Text "Cannot use projective coordinates with an arrayed image." ) + +-- which coordinates to use to provide explicit derivatives +type family GradCoordinatesDim + ( props :: Dimensionality ) + ( ops :: [OperandName] ) + :: Nat where + GradCoordinatesDim dim ops = + If ( ProjectiveCoords `Elem` ops ) + ( ComputeCoordsDim dim NonArrayed Projective ) + ( ComputeCoordsDim dim NonArrayed Affine ) + +-- which coordinates to use to provide an offset +type family OffsetCoordinatesDim + ( props :: Dimensionality ) + ( ops :: [OperandName] ) + :: Nat where + OffsetCoordinatesDim dim ops = + If ( ProjectiveCoords `Elem` ops ) + ( ComputeCoordsDim dim NonArrayed Projective ) + ( ComputeCoordsDim dim NonArrayed Affine ) + + +----------------------------------------------------------- +-- Validation of image operands. + +-- this type family could be slightly more specific +-- and enforce that e.g. reading from an 'Unsigned Integer' image format +-- necessarily returns unsigned integers +-- the 'No instance ...' error message can also be a bit confusing +type family MatchesFormat + ( fmt :: Maybe (ImageFormat Nat) ) + ( a :: Type ) + :: Constraint where + MatchesFormat (Just ('ImageFormat I _)) a = Integral a + MatchesFormat (Just ('ImageFormat UI _)) a = Integral a + MatchesFormat (Just ('ImageFormat _ _)) a = Floating a + MatchesFormat _ _ = () + +type family BasicDim (opName :: Symbol) (props :: ImageProperties) :: Constraint where + BasicDim _ ( Properties _ _ OneD _ _ _ _ _ ) = () + BasicDim _ ( Properties _ _ TwoD _ _ _ _ _ ) = () + BasicDim _ ( Properties _ _ ThreeD _ _ _ _ _ ) = () + BasicDim _ ( Properties _ _ Cube _ _ _ _ _ ) = () + BasicDim opName ( Properties _ _ dim _ _ _ _ _ ) + = TypeError + ( Text opName :<>: Text " operand: unexpected image dimensionality " + :<>: ShowType dim :<>: Text "." + :$$: Text "Image dimensionality must be 'OneD', 'TwoD', 'ThreeD' or 'Cube'. " + ) + +type family NotCubeDim (opName :: Symbol) (props :: ImageProperties) :: Constraint where + NotCubeDim opName ( Properties _ _ Cube _ _ _ _ _ ) + = TypeError + ( Text opName :<>: Text " operand: unexpected 'Cube' image dimensionality." + :$$: Text "Image dimensionality must not be 'Cube'." + ) + NotCubeDim _ _ = () + +type family CanAddProj (ops :: [OperandName]) :: Constraint where + CanAddProj '[] = () + CanAddProj ( ProjectiveCoords ': _ ) + = TypeError ( Text "'Proj' operand already supplied." ) + CanAddProj ( DepthComparison ': ops ) = CanAddProj ops + CanAddProj ( op ': _ ) + = TypeError ( Text "'Proj' operand must be provided after " :<>: ShowType op ) + +type family CanAddDref (ops :: [OperandName]) :: Constraint where + CanAddDref '[] = () + CanAddDref ( DepthComparison ': _ ) + = TypeError ( Text "'Dref' operand already supplied." ) + CanAddDref ( ProjectiveCoords ': ops ) = CanAddDref ops + CanAddDref ( op ': _ ) + = TypeError ( Text "'Dref' operand must be provided after " :<>: ShowType op ) + +type family UsesAffineCoords (ops :: [OperandName]) :: Constraint where + UsesAffineCoords '[] = () + UsesAffineCoords ( ProjectiveCoords ': _ ) + = TypeError ( Text "'Gather': unexpected 'Proj' operand; cannot use projective coordinates." ) + UsesAffineCoords ( _ ': ops ) = UsesAffineCoords ops + +type NoDuplicate op ops = NoDuplicateFromElem op (op `Elem` ops) + +type family NoDuplicateFromElem op dup :: Constraint where + NoDuplicateFromElem _ False = () + NoDuplicateFromElem op True + = TypeError ( Text "Duplicate image operand " :<>: ShowType op :<>: Text "." ) + +type family NoMS (opName :: Symbol) (props :: ImageProperties) :: Constraint where + NoMS _ (Properties _ _ _ _ _ SingleSampled _ _) = () + NoMS opName _ + = TypeError + ( Text opName :<>: Text " operand: image cannot be multisampled." ) + +type family CanMultiSample (ms :: ImageProperties) :: Constraint where + CanMultiSample (Properties _ _ _ _ _ SingleSampled _ _) + = TypeError ( Text "Cannot multi-sample this single-sampled image." ) + CanMultiSample _ = () + +type family NoLODOps + ( name :: Symbol ) + ( excl :: [LOD.LODOperand] ) + ( ops :: [OperandName] ) + :: Constraint + where + NoLODOps _ _ '[] = () + NoLODOps name excl (BaseOperand ('LODOperand op) ': ops) + = If + (op `Elem` excl) + ( TypeError + ( Text "Cannot provide " :<>: ShowType name :<>: Text " operand:" + :$$: ShowType op :<>: Text " operand already provided." + ) + ) + ( NoLODOps name excl ops ) + NoLODOps name excl ( _ ': ops ) = NoLODOps name excl ops + +type family SupportsDepthTest ( props :: ImageProperties ) :: Constraint where + SupportsDepthTest (Properties _ _ _ (Just NotDepthImage) _ _ _ _) + = TypeError ( Text "Cannot do a depth comparison: image is not a depth image." ) + SupportsDepthTest _ = () + +----------------------------------------------------------- +-- Validation of image query operations. + +type ValidQueryImageSizeLOD ( imgName :: Symbol ) ( i :: ProgramState ) ( res :: Type ) + = ValidQueryImageSizeLODFromProps imgName ( LookupImageProperties imgName i ) res + +type ValidQueryImageSize ( imgName :: Symbol ) ( i :: ProgramState ) ( res :: Type ) + = ValidQueryImageSizeFromProps imgName ( LookupImageProperties imgName i ) res + +type ValidQueryImageLOD ( imgName :: Symbol ) ( i :: ProgramState ) ( coords :: Type ) ( res :: Type ) + = ValidQueryImageLODFromProps imgName ( LookupImageProperties imgName i ) coords res + +type ValidQueryImageLevels ( imgName :: Symbol ) ( i :: ProgramState ) ( res :: Type ) + = ValidQueryImageLevelsFromProps imgName ( LookupImageProperties imgName i ) res + +type ValidQueryImageSamples ( imgName :: Symbol ) ( i :: ProgramState ) ( res :: Type ) + = ValidQueryImageSamplesFromProps imgName ( LookupImageProperties imgName i ) res + + +-- ImageQuerySizeLod + +type family ValidQueryImageSizeLODFromProps ( imgName :: Symbol ) ( imgProps :: ImageProperties ) ( res :: Type ) :: Constraint where + ValidQueryImageSizeLODFromProps imgName ( Properties _ _ _ _ _ MultiSampled _ _ ) res = + TypeError + ( Text "Cannot query size (with explicit LOD) of multi-sampled image " :<>: ShowType imgName ) + ValidQueryImageSizeLODFromProps imgName ( Properties _ _ dim _ arr _ _ _ ) res = + ( ValidCoordinateType "image coordinates (for querying)" (ImageCoordinatesDim dim arr '[]) IntegralCoordinates res + , ValidImageSizeLODQueryDim imgName dim + ) + +type family ValidImageSizeLODQueryDim ( imgName :: Symbol ) ( dim :: Dimensionality ) :: Constraint where + ValidImageSizeLODQueryDim _ OneD = () + ValidImageSizeLODQueryDim _ TwoD = () + ValidImageSizeLODQueryDim _ ThreeD = () + ValidImageSizeLODQueryDim _ Cube = () + ValidImageSizeLODQueryDim imgName dim = + TypeError + ( Text "Cannot query the size (with explicit LOD) of image " :<>: ShowType imgName :<>: Text "." + :$$: Text "Unsupported dimensionality " :<>: ShowType dim :<>: Text "." + ) + +-- ImageQuerySize + +type family ValidQueryImageSizeFromProps ( imgName :: Symbol ) ( imgProps :: ImageProperties ) ( res :: Type ) :: Constraint where + ValidQueryImageSizeFromProps imgName ( Properties _ _ dim _ arr ms usage _ ) res = + ( ValidCoordinateType "image coordinates (for querying)" (ImageCoordinatesDim dim arr '[]) IntegralCoordinates res + , ValidImageSizeQueryDim imgName dim ms usage + ) + +type family ValidImageSizeQueryDim ( imgName :: Symbol ) ( dim :: Dimensionality ) ( ms :: MultiSampling ) ( usage :: ImageUsage ) :: Constraint where + ValidImageSizeQueryDim _ Rect _ _ = () + ValidImageSizeQueryDim _ Buffer _ _ = () + ValidImageSizeQueryDim imgName SubpassData _ _ = + TypeError + ( Text "Cannot query the size (without LOD) of image " :<>: ShowType imgName :<>: Text "." + :$$: Text "Unsupported dimensionality " :<>: ShowType SubpassData :<>: Text "." + ) + ValidImageSizeQueryDim imgName dim SingleSampled Sampled = + TypeError + ( Text "Cannot query the size (without LOD) of image " :<>: ShowType imgName :<>: Text "." + :$$: Text "Unsupported combination:" + :$$: Text " - dimensionality " :<>: ShowType dim :<>: Text "," + :$$: Text " - no multisampling," + :$$: Text " - image used with a sampler." + ) + ValidImageSizeQueryDim _ _ _ _ = () + + +-- ImageQueryLod + +type family ValidQueryImageLODFromProps ( imgName :: Symbol ) ( imgProps :: ImageProperties ) ( coords :: Type ) ( res :: Type ) :: Constraint where + ValidQueryImageLODFromProps imgName ( Properties coordKind _ dim _ arr _ _ _ ) coords res = + ( QueryLODIsV2Floating imgName res + , ValidCoordinateType "image coordinates (for querying LOD)" (ImageCoordinatesDim dim arr '[]) coordKind res -- TODO: enforce floating point coordinates outside of ComputeKernel? + , ValidImageLODQueryDim imgName dim + ) + +type family QueryLODIsV2Floating ( imgName :: Symbol ) ( res :: Type ) :: Constraint where + QueryLODIsV2Floating _ ( V 2 a ) = Floating a + QueryLODIsV2Floating imgName t = + TypeError + ( Text "Unexpected result type " :<>: ShowType t + :$$: Text "when querying LOD for image named " :<>: ShowType imgName :<>: Text "." + :$$: Text "Result type should be a 2-component floating-point type vector." + ) + +type family ValidImageLODQueryDim ( imgName :: Symbol ) ( dim :: Dimensionality ) :: Constraint where + ValidImageLODQueryDim _ OneD = () + ValidImageLODQueryDim _ TwoD = () + ValidImageLODQueryDim _ ThreeD = () + ValidImageLODQueryDim _ Cube = () + ValidImageLODQueryDim imgName dim = + TypeError + ( Text "Cannot query the LOD of image " :<>: ShowType imgName :<>: Text "." + :$$: Text "Unsupported dimensionality " :<>: ShowType dim :<>: Text "." + ) + +-- ImageQueryLevels + +type family ValidQueryImageLevelsFromProps ( imgName :: Symbol ) ( imgProps :: ImageProperties ) ( res :: Type ) :: Constraint where + ValidQueryImageLevelsFromProps imgName ( Properties _ _ dim _ _ _ _ _ ) res = + ( Integral res + , ValidImageLevelsQueryDim imgName dim + ) + +type family ValidImageLevelsQueryDim ( imgName :: Symbol ) ( dim :: Dimensionality ) :: Constraint where + ValidImageLevelsQueryDim _ OneD = () + ValidImageLevelsQueryDim _ TwoD = () + ValidImageLevelsQueryDim _ ThreeD = () + ValidImageLevelsQueryDim _ Cube = () + ValidImageLevelsQueryDim imgName dim = + TypeError + ( Text "Cannot query the number of accessible mipmap levels of image named " :<>: ShowType imgName :<>: Text "." + :$$: Text "Unsupported dimensionality " :<>: ShowType dim :<>: Text "." + ) + +-- ImageQuerySamples + +type family ValidQueryImageSamplesFromProps ( imgName :: Symbol ) ( imgProps :: ImageProperties ) ( res :: Type ) :: Constraint where + ValidQueryImageSamplesFromProps _ ( Properties _ _ TwoD _ _ MultiSampled _ _ ) res = Integral res + ValidQueryImageSamplesFromProps imgName ( Properties _ _ dim _ _ MultiSampled _ _ ) _ = + TypeError + ( Text "Cannot query the number of samples of image named " :<>: ShowType imgName :<>: Text "." + :$$: Text "This image has unsupported dimensionality " :<>: ShowType dim :<>: Text "." + :$$: Text "Expected a TwoD dimensionality." + ) + ValidQueryImageSamplesFromProps imgName ( Properties _ _ _ _ _ _ _ _ ) _ = + TypeError + ( Text "Cannot query the number of samples of image named " :<>: ShowType imgName :<>: Text "." + :$$: Text "This image is not multi-sampled." + ) diff --git a/src/FIR/Validation/Interface.hs b/src/FIR/Validation/Interface.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/Interface.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.Interface + +Validates the layout of individual entry point input/output interfaces. + +For instance: + + * inputs/outputs in entry point interfaces must not overlap, + * types within a location must use a consistent base type, + e.g. a 'Float' and a 'Word32' cannot share a location. + +-} + +module FIR.Validation.Interface + ( ValidInterface ) + where + +-- base +import Data.Kind + ( Type, Constraint ) +import GHC.TypeLits + ( Symbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.Map + ( (:->)((:->)), Lookup ) +import Data.Type.Maybe + ( SequenceMaybe ) +import FIR.Prim.Struct + ( LocationSlot(LocationSlot) ) +import FIR.ProgramState + ( TLInterfaceVariable + , EntryPointInfo(EntryPointInfo) + ) +import FIR.Validation.Arrayness + ( IsPatchVariable(..), ImplicitArrayness(..) + , Arrayness, RemoveArrayness + ) +import FIR.Validation.Layout + ( ValidLayout ) +import qualified SPIRV.Decoration as SPIRV + ( Decoration(..) ) +import qualified SPIRV.Stage as SPIRV + ( ExecutionModel(..), ExecutionInfo(..) ) +import qualified SPIRV.Storage as SPIRV + ( StorageClass(Input,Output) ) + +------------------------------------------------------------------------ + +type family ValidInterface ( epName :: Symbol ) ( nfo :: EntryPointInfo ) :: Constraint where + ValidInterface epName ( 'EntryPointInfo xNfo globals _ ) + = ( ValidLayout ( LocationSlotsFromDecorations epName xNfo SPIRV.Input ( SequenceMaybe ( Lookup SPIRV.Input globals ) ) ) + , ValidLayout ( LocationSlotsFromDecorations epName xNfo SPIRV.Output ( SequenceMaybe ( Lookup SPIRV.Output globals ) ) ) + ) + +type family LocationSlotsFromDecorations + ( emName :: Symbol ) + ( xNfo :: SPIRV.ExecutionInfo Nat em ) + ( inOut :: SPIRV.StorageClass ) + ( globals :: [ Symbol :-> TLInterfaceVariable ] ) + :: [ LocationSlot Nat :-> Type ] + where + LocationSlotsFromDecorations _ _ _ '[] = '[] + LocationSlotsFromDecorations + emName ( xNfo :: SPIRV.ExecutionInfo Nat em ) + inOut ( ( varName ':-> '(decs, ty) ) ': globals ) + = AddLocationSlotIfNecessary varName ty decs emName em inOut + ( Arrayness inOut decs xNfo ) + ( LocationSlotsFromDecorations emName xNfo inOut globals ) + +type family AddLocationSlotIfNecessary + ( varName :: Symbol ) + ( ty :: Type ) + ( decs :: [ SPIRV.Decoration Nat ] ) + ( emName :: Symbol ) + ( em :: SPIRV.ExecutionModel ) + ( inOut :: SPIRV.StorageClass ) + ( arrayness :: ImplicitArrayness ) + ( slots :: [ LocationSlot Nat :-> Type ] ) + :: [ LocationSlot Nat :-> Type ] + where + AddLocationSlotIfNecessary _ _ _ _ _ _ ('NoImplicitArrayness 'IsPatch) slots + -- ignore patch variables + = slots + -- otherwise, add the located type (after removing the implicit arrayness) + AddLocationSlotIfNecessary varName ty decs emName em inOut arrayness slots + = AddLocationSlot varName + ( RemoveArrayness varName inOut emName em ty arrayness ) + ( LocationDecorations decs ) + slots + +type family AddLocationSlot + ( k :: Symbol ) + ( ty :: Type ) + ( locInfo :: ( [Nat], [Nat] ) ) + ( slots :: [ LocationSlot Nat :-> Type ] ) + :: [ LocationSlot Nat :-> Type ] + where + AddLocationSlot k ty locInfo slots + = ( LocationSlotFromDecorations k locInfo ':-> ty ) ': slots + +type family LocationSlotFromDecorations + ( k :: Symbol ) + ( locInfo :: ( [Nat], [Nat] ) ) + :: LocationSlot Nat + where + LocationSlotFromDecorations _ '( '[l] , '[c] ) + = 'LocationSlot l c + LocationSlotFromDecorations _ '( '[l] , '[] ) + = 'LocationSlot l 0 + LocationSlotFromDecorations k '( '[l] , cs ) + = TypeError + ( Text "Global named " :<>: ShowType k + :<>: Text " has more than one 'Component' decoration:" + :$$: ShowType cs + ) + LocationSlotFromDecorations k '( '[] , _ ) + = TypeError + ( Text "Global named " :<>: ShowType k + :<>: Text " is missing a 'Location' decoration." + ) + LocationSlotFromDecorations k '( ls , _ ) + = TypeError + ( Text "Global named " :<>: ShowType k + :<>: Text " has more than one 'Location' decoration:" + :$$: ShowType ls + ) + +type family LocationDecorations + ( decs :: [SPIRV.Decoration Nat] ) + :: ( [Nat], [Nat] ) + where + LocationDecorations '[] = '( '[], '[] ) + LocationDecorations ( SPIRV.Location l ': decs ) + = CombineLocations '( Just l, 'Nothing ) ( LocationDecorations decs ) + LocationDecorations ( SPIRV.Component c ': decs ) + = CombineLocations '( 'Nothing, 'Just c ) ( LocationDecorations decs ) + LocationDecorations ( _ ': decs ) = LocationDecorations decs + +type family CombineLocations + ( lc :: ( Maybe Nat, Maybe Nat ) ) + ( lcs :: ( [Nat], [Nat] ) ) + :: ( [Nat], [Nat] ) + where + CombineLocations '(Just l, Just c) '(ls, cs) = '( l ': ls, c ': cs ) + CombineLocations '(Just l, _ ) '(ls, cs) = '( l ': ls, cs ) + CombineLocations '(_ , Just c) '(ls, cs) = '( ls, c ': cs ) + CombineLocations _ lcs = lcs diff --git a/src/FIR/Validation/Layout.hs b/src/FIR/Validation/Layout.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/Layout.hs @@ -0,0 +1,514 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.Layout + +Validation module for GPU memory layout, e.g. shader location/component assignments. + +To specify the layout of vertex input data, the user specifies the type of inhabitants +in the available memory locations. Each location holds four components, +with each component of size 32 bits (4 bytes), i.e. the size of a 'Float'. +The type-system checks the compliance of any user-supplied layout with the SPIR-V and Vulkan specifications, +in particular checking that the assignment of slots is non-overlapping. + +For instance, suppose we want to lay out objects of the following types: + + [@A@] @Array 3 (V 2 Float)@ + + [@B@] @Array 2 Float@ + + [@C@] @Float@ + + [@D@] @V 3 Double@ + + [@E@] @Array 2 Double@ + + [@F@] @M 2 3 Float@ + +We can lay out this data by specifying which location slots each type uses. +Consider for instance the following specification: + +> Struct +> '[ Slot 0 0 ':-> Array 3 (V 2 Float) +> , Slot 0 2 ':-> Array 2 Float +> , Slot 1 3 ':-> Float +> , Slot 3 0 ':-> V 3 Double +> , Slot 4 2 ':-> Array 2 Double +> , Slot 6 0 ':-> M 2 3 Float +> ] + +We can visualise this layout as follows, +each row representing a location (each consisting of 4 components): + +\[ +\begin{matrix} + & 0 & 1 & 2 & 3 \\ +0 & \color{brown}{A} & \color{brown}{A} & \color{RoyalBlue}{B} & \circ \\ +1 & \color{brown}{A} & \color{brown}{A} & \color{RoyalBlue}{B} & \color{purple}{C} \\ +2 & \color{brown}{A} & \color{brown}{A} & \circ & \circ \\ +3 & \color{Plum}{D} & \color{Plum}{D} & \color{Plum}{D} & \color{Plum}{D} \\ +4 & \color{Plum}{D} & \color{Plum}{D} & \color{orange}{E} & \color{orange}{E} \\ +5 & \circ & \circ & \color{orange}{E} & \color{orange}{E} \\ +6 & \color{green}{F} & \color{green}{F} & \color{green}{\times} & \color{green}{\times} \\ +7 & \color{green}{F} & \color{green}{F} & \color{green}{\times} & \color{green}{\times} \\ +8 & \color{green}{F} & \color{green}{F} & \color{green}{\times} & \color{green}{\times} +\end{matrix} +\] + +Here \( \circ \) denotes unused components that are still available for other data, +whereas \( \times \) denotes unused components that /cannot/ be filled with other data. + +Note in particular that matrices use as many locations as they have columns, consuming each location in its entirety. + +The specification guarantees that locations 0 to 15 will be available. The availability of further locations +will depend on the GPU and its implementation of Vulkan. + +For further reference, see: + + - SPIR-V specification, 2.16.2 "Validation Rules for Shader Capabilities", bullet point 3, + - SPIR-V specification, 2.18.1 "Memory Layout", + - Vulkan specification, 14.1.4 "Location Assignment", and 14.1.5 "Component Assignment", + - Vulkan specification, 14.5.2 "Descriptor Set Interface", and 14.5.4 "Offset and Stride Assignment". + +See also "FIR.Layout" for further information concerning memory layout. + +-} + +module FIR.Validation.Layout where + +-- base +import Data.Kind + ( Type, Constraint ) +import Data.Type.Bool + ( If, type (&&), type (||) ) +import Data.Type.Equality + ( type (==) ) +import GHC.TypeLits + ( TypeError, ErrorMessage(..) ) +import GHC.TypeNats + ( Nat + , type (+), type (-) + , type (*), Div, Mod + ) + +-- fir +import Data.Type.Error + ( IsRight ) +import Data.Type.List + ( Elem ) +import Data.Type.Map + ( (:->)((:->)) ) +import Data.Type.Maybe + ( IfNothingThen ) +import Data.Type.POrd + ( POrd(..) + , PEnum(EnumFromOfCount) + ) +import Data.Type.String + ( ShowNat ) +import FIR.Layout + ( Components ) +import FIR.Prim.Array + ( Array(..) ) +import FIR.Prim.Struct + ( LocationSlot(LocationSlot) + , ShowLocationSlot + ) +import FIR.Prim.Types + ( SScalarTy, ScalarWidth + , ScalarFromSScalar + , SKPrimTy(..), PrimTySing + ) +import Math.Linear + ( V, M ) +import qualified SPIRV.ScalarTy as SPIRV + ( ScalarTy(Integer, Floating) ) + +----------------------------------------------------------------------------------------------------- +-- Layout validation. + +-- | Validate the layout of a collection of located types. +type family ValidLayout (as :: [LocationSlot Nat :-> Type]) :: Constraint where + ValidLayout '[] = () + ValidLayout ( ( loc ':-> ty ) ': slots ) + = ( IsRight ( ValidateSlot loc ( PrimTySing ty ) ) -- validate individual slot + , CheckOverlaps ( loc ':-> ty ) slots -- pairwise overlap checks + , ValidLayout slots + ) + +----------------------------------------------------------------------------------------------------- +-- Individual validation of slots. + +-- | Validate an individual location slot. +type family ValidateSlot + ( loc :: LocationSlot Nat ) + ( sing :: SKPrimTy ty ) + :: Either ErrorMessage () + where + ValidateSlot _ SKUnit + = Left + ( Text "Unit type not supported here." ) + ValidateSlot _ SKBool + = Left + ( Text "Booleans not supported here. Suggestion: use 'Word32' instead." ) + ValidateSlot ('LocationSlot l c) (SKScalar s :: SKPrimTy ty) + = If ( c :<= 3 && ( c `Mod` 2 == 0 || ScalarWidth s :<= 32 ) ) + ( Right '() ) + ( Left + ( Text "Cannot position scalar of type " :<>: ShowType ty + :$$: Text " at " :<>: Text (ShowLocationSlot ('LocationSlot l c)) :<>: Text "." + ) + ) + ValidateSlot ('LocationSlot l c) (SKVector s :: SKPrimTy (V n a)) + = If ( n :> 4 || n :< 2 ) + ( Left + ( Text "Unexpected vector dimensions " + :<>: ShowType (V n a) + :$$: Text " at " :<>: Text (ShowLocationSlot ('LocationSlot l c)) :<>: Text "." + ) + ) + ( If ( c == 0 || ( c `Mod` 2 == 0 && c :<= 3 && n :<= 2 && ScalarWidth s :<= 32 ) ) + ( Right '() ) + ( Left + ( Text "Cannot position vector of type " + :<>: ShowType (V n a) + :$$: Text " at " :<>: Text (ShowLocationSlot ('LocationSlot l c)) :<>: Text "." + ) + ) + ) + ValidateSlot ('LocationSlot l 0) (SKMatrix s :: SKPrimTy (M m n a)) + = If ( n :<= 4 && m :<= 4 && n :> 1 && m :> 1 ) + ( Right '() ) + ( Left + ( Text "Unexpected matrix dimensions " + :<>: ShowType (M m n a) + :$$: Text " at " :<>: Text (ShowLocationSlot ('LocationSlot l 0)) :<>: Text "." + ) + ) + ValidateSlot ('LocationSlot l c) (SKMatrix s :: SKPrimTy (M m n a)) + = Left + ( Text "Cannot position matrix at location " :<>: ShowType l + :<>: Text " with non-zero component " :<>: ShowType c :<>: Text "." + ) + ValidateSlot loc (SKArray _ :: SKPrimTy (Array 0 a)) + = Left ( Text "Unexpected size 0 array at " :<>: Text (ShowLocationSlot loc) :<>: Text "." ) + ValidateSlot loc (SKArray elt :: SKPrimTy (Array l a)) + = ValidateArraySlot loc (Array l a) (ValidateSlot loc elt) + ValidateSlot loc (SKRuntimeArray _) + = Left ( Text "Unexpected runtime array at " :<>: Text (ShowLocationSlot loc) :<>: Text "." ) + ValidateSlot loc (SKStruct _) + = Left + ( Text "Unexpected struct at " :<>: Text (ShowLocationSlot loc) :<>: Text "." + :$$: Text "Structs not (yet?) supported in inputs/outputs." + ) + +type family ValidateArraySlot + ( loc :: LocationSlot Nat ) + ( arr :: Type ) + ( ok :: Either ErrorMessage () ) + :: Either ErrorMessage () + where + ValidateArraySlot loc arr (Left err) + = Left + ( Text "Attempting to position " :<>: ShowType arr + :<>: Text " at " :<>: Text (ShowLocationSlot loc) + :<>: Text " has caused the following error:" + :$$: err + ) + ValidateArraySlot _ _ _ = Right '() + +----------------------------------------------------------------------------------------------------- +-- Check overlap within a collection of located types. + +-- | Data (kind) recording problematic overlap between located types. +data Overlap + = OverlappingSlot (LocationSlot Nat) -- ^ Location + component overlap. + | OverlappingLocation Nat Type Type -- ^ Location overlap with incompatible underlying scalar types. + +type family CheckOverlaps + ( slot :: ( LocationSlot Nat :-> Type ) ) + ( slots :: [ LocationSlot Nat :-> Type ] ) + :: Constraint + where + CheckOverlaps _ '[] = () + CheckOverlaps slot ( s ': ss ) = ( CheckOverlap slot s, CheckOverlaps slot ss ) + +type family CheckOverlap + ( slot1 :: ( LocationSlot Nat :-> Type ) ) + ( slot2 :: ( LocationSlot Nat :-> Type ) ) + :: Constraint + where + CheckOverlap ( loc1 ':-> ty1 ) ( loc2 ':-> ty2 ) + = ValidateOverlap + loc1 ty1 + loc2 ty2 + ( ComputeFirstOverlap + loc1 ( PrimTySing ty1 ) + loc2 ( PrimTySing ty2 ) + ) + +type family ValidateOverlap + ( loc1 :: LocationSlot Nat ) + ( ty1 :: Type ) + ( loc2 :: LocationSlot Nat ) + ( ty2 :: Type ) + ( overlap :: Maybe Overlap ) + :: Constraint + where + ValidateOverlap + _ _ + _ _ + 'Nothing + = () + ValidateOverlap + slot1 ty1 + slot2 ty2 + ( Just (OverlappingSlot overlapSlot) ) + = TypeError + ( Text "Overlap at " :<>: Text (ShowLocationSlot overlapSlot) :<>: Text ":" + :$$: Text " - " :<>: ShowType ty1 :<>: Text " with " + :<>: Text (ShowLocationSlot slot1) :<>: Text "," + :$$: Text " - " :<>: ShowType ty2 :<>: Text " with " + :<>: Text (ShowLocationSlot slot2) :<>: Text "." + ) + ValidateOverlap + slot1 ty1 + slot2 ty2 + ( Just (OverlappingLocation loc scalar1 scalar2 ) ) + = TypeError + ( Text "Incompatible scalars within Location " :<>: Text (ShowNat loc) :<>: Text ":" + :$$: Text " - " :<>: ShowType ty1 :<>: Text " with " :<>: Text (ShowLocationSlot slot1) + :<>: Text " requires " :<>: ShowType scalar1 :<>: Text "," + :$$: Text " - " :<>: ShowType ty2 :<>: Text " with " :<>: Text (ShowLocationSlot slot2) + :<>: Text " requires " :<>: ShowType scalar2 :<>: Text "." + ) + +-- | Compute the first problematic overlap between any two pairs of located types. +-- +-- This computation is done explicitly, to avoid building up any large +-- intermediate structures. +-- +-- Only needs to cover pairs of the following types: +-- +-- * scalars, +-- * vectors, +-- * matrices, +-- * arrays of any of the above (but not arrays of arrays). +-- +-- Other types are not (currently) allowed in inputs/outputs. +type family ComputeFirstOverlap + ( loc1 :: LocationSlot Nat ) + ( skty1 :: SKPrimTy ty1 ) + ( loc2 :: LocationSlot Nat ) + ( skty2 :: SKPrimTy ty2 ) + :: Maybe Overlap + where + -- scalar - scalar + ComputeFirstOverlap + ( 'LocationSlot l c1 ) ( SKScalar s1 :: SKPrimTy ty1 ) + ( 'LocationSlot l c2 ) ( SKScalar s2 :: SKPrimTy ty2 ) + = FirstOverlapFromEnum l + ( 'LocationSlot l c1 ) ty1 s1 + ( 'LocationSlot l c2 ) ty2 s2 + -- (scalars are always contained within a single location) + ComputeFirstOverlap + ( 'LocationSlot l1 _ ) ( SKScalar _ ) + ( 'LocationSlot l2 _ ) ( SKScalar _ ) + = Nothing + -- scalar - vector + ComputeFirstOverlap + ( 'LocationSlot l1 c1 ) ( SKScalar s1 :: SKPrimTy ty1 ) + ( 'LocationSlot l2 c2 ) ( SKVector s2 :: SKPrimTy (V m2 ty2) ) + = If ( l1 :< l2 || l1 :>= ( l2 + VectorLocations m2 s2 ) ) + Nothing -- no overlap possible + ( FirstOverlapFromEnum l1 + ( 'LocationSlot l1 c1 ) ty1 s1 + ( 'LocationSlot l2 c2 ) (V m2 ty2) s2 + ) + -- vector - scalar: reduce to scalar - vector + ComputeFirstOverlap + ( 'LocationSlot l1 c1 ) ( SKVector s1 :: SKPrimTy (V m1 ty1) ) + ( 'LocationSlot l2 c2 ) ( SKScalar s2 :: SKPrimTy ty2 ) + = FmapSwapOverlap + ( ComputeFirstOverlap + ( 'LocationSlot l2 c2 ) ( SKScalar s2 :: SKPrimTy ty2 ) + ( 'LocationSlot l1 c1 ) ( SKVector s1 :: SKPrimTy (V m1 ty1) ) + ) + -- vector - vector + ComputeFirstOverlap + ( 'LocationSlot l1 c1 ) ( SKVector s1 :: SKPrimTy (V m1 ty1) ) + ( 'LocationSlot l2 c2 ) ( SKVector s2 :: SKPrimTy (V m2 ty2) ) + = If ( l1 :>= ( l2 + VectorLocations m2 s2 ) + || l2 :>= ( l1 + VectorLocations m1 s1 ) + ) + Nothing -- no overlap possible + ( -- in this case, a unique location is used by both vectors: Max l1 l2 + FirstOverlapFromEnum (Max l1 l2) + ( 'LocationSlot l1 c1 ) (V m1 ty1) s1 + ( 'LocationSlot l2 c2 ) (V m2 ty2) s2 + ) + -- scalar - matrix + -- only need to check location overlap; + -- no need to worry about components, as matrices consume locations entirely + ComputeFirstOverlap + ( 'LocationSlot l1 c1 ) ( SKScalar s1 :: SKPrimTy ty1 ) + ( 'LocationSlot l2 _ ) ( SKMatrix s2 :: SKPrimTy (M m2 n2 ty2) ) + = If ( l1 :< l2 || l1 :>= ( l2 + MatrixLocations n2 s2 ) ) + Nothing + ( Just ( 'OverlappingSlot ( 'LocationSlot l1 c1 ) ) ) + -- matrix - scalar: reduce to scalar - matrix + ComputeFirstOverlap + loc1 ( SKMatrix s1 :: SKPrimTy (M m1 n1 ty1) ) + loc2 ( SKScalar s2 :: SKPrimTy ty2 ) + = FmapSwapOverlap + ( ComputeFirstOverlap + loc2 ( SKScalar s2 :: SKPrimTy ty2 ) + loc1 ( SKMatrix s1 :: SKPrimTy (M m1 n1 ty1) ) + ) + -- vector - matrix + -- essentially the same as scalar - matrix, + -- except that the vector might take up two locations + ComputeFirstOverlap + ( 'LocationSlot l1 c1 ) ( SKVector s1 :: SKPrimTy (V m1 ty1) ) + ( 'LocationSlot l2 _ ) ( SKMatrix s2 :: SKPrimTy (M m2 n2 ty2) ) + = If ( ( l2 :>= ( l1 + VectorLocations m1 s1 ) ) + || ( l1 :>= ( l2 + MatrixLocations n2 s2 ) ) + ) + Nothing + ( If ( l1 :< l2 ) + ( Just ( 'OverlappingSlot ( 'LocationSlot (l1 + 1) 0 ) ) ) + ( Just ( 'OverlappingSlot ( 'LocationSlot l1 c1 ) ) ) + ) + -- matrix - vector: reduce to vector - matrix + ComputeFirstOverlap + loc1 ( SKMatrix s1 :: SKPrimTy (M m1 n1 ty1) ) + loc2 ( SKVector s2 :: SKPrimTy (V m2 ty2) ) + = FmapSwapOverlap + ( ComputeFirstOverlap + loc2 ( SKVector s2 :: SKPrimTy (V m2 ty2) ) + loc1 ( SKMatrix s1 :: SKPrimTy (M m1 n1 ty1) ) + ) + -- matrix - matrix + ComputeFirstOverlap + ( 'LocationSlot l1 _ ) ( SKMatrix s1 :: SKPrimTy (M m1 n1 ty1) ) + ( 'LocationSlot l2 _ ) ( SKMatrix s2 :: SKPrimTy (M m2 n2 ty2) ) + = If ( ( l2 :>= ( l1 + MatrixLocations n1 s1 ) ) + || ( l1 :>= ( l2 + MatrixLocations n2 s2 ) ) + ) + Nothing + ( Just ( OverlappingSlot ( 'LocationSlot ( Max l1 l2 ) 0 ) ) ) + -- arrays + ComputeFirstOverlap + _ ( SKArray _ :: SKPrimTy (Array 0 ty1) ) + _ _ + = Nothing + ComputeFirstOverlap + loc1 ( SKArray elt :: SKPrimTy (Array 1 ty1) ) + loc2 sing2 + = ComputeFirstOverlap loc1 elt loc2 sing2 + ComputeFirstOverlap + ( 'LocationSlot l1 c1 ) ( SKArray elt1 :: SKPrimTy (Array n1 ty1) ) + ( 'LocationSlot l2 c2 ) ( sing2 :: SKPrimTy ty2 ) + = If ( ( l1 + n1 * ( Components ty1 `Div` 4 ) ) :< l2 ) + Nothing + ( ( ComputeFirstOverlap + ( 'LocationSlot l1 c1 ) elt1 + ( 'LocationSlot l2 c2 ) sing2 + ) + `IfNothingThen` + ( ComputeFirstOverlap + ( 'LocationSlot + ( l1 + 1 + ( Components ty1 `Div` 4 ) ) + c1 + ) + ( SKArray elt1 :: SKPrimTy ( Array (n1-1) ty1) ) + ( 'LocationSlot l2 c2 ) sing2 + ) + ) + ComputeFirstOverlap + loc1 sing1 + loc2 ( SKArray elt2 :: SKPrimTy (Array n2 ty2) ) + = FmapSwapOverlap + ( ComputeFirstOverlap + loc2 ( SKArray elt2 :: SKPrimTy (Array n2 ty2) ) + loc1 sing1 + ) + +-- | Helper function to accomodate for switching arguments. +type family FmapSwapOverlap ( overlap :: Maybe Overlap ) :: Maybe Overlap where + FmapSwapOverlap Nothing = Nothing + FmapSwapOverlap (Just (OverlappingSlot slot)) = Just (OverlappingSlot slot) + FmapSwapOverlap (Just (OverlappingLocation i ty1 ty2)) + = Just (OverlappingLocation i ty2 ty1) + +type family VectorLocations (m :: Nat) (s :: SScalarTy ty) :: Nat where + VectorLocations m s = If ( ScalarWidth s :<= 32 || m :<= 2 ) 1 2 + +type family MatrixLocations (n :: Nat) (s :: SScalarTy ty) :: Nat where + MatrixLocations n s = n * VectorLocations 4 s + +type family FirstOverlapFromEnum + ( loc :: Nat ) -- location used for 'OverlappingLocation' + ( loc1 :: LocationSlot Nat ) + ( ty1 :: Type ) + ( s1 :: SScalarTy scal1 ) + ( loc2 :: LocationSlot Nat ) + ( ty2 :: Type ) + ( s2 :: SScalarTy scal2 ) + :: Maybe Overlap + where + FirstOverlapFromEnum loc + loc1 ty1 (s1 :: SScalarTy scal1) + loc2 ty2 (s2 :: SScalarTy scal2) + = ( FirstOverlappingSlot + ( EnumConsecutiveSlots loc1 ty1 ) + ( EnumConsecutiveSlots loc2 ty2 ) + ) + `IfNothingThen` + ( If ( CompatibleSScalars s1 s2 ) + Nothing + ( Just ('OverlappingLocation loc scal1 scal2 ) ) + ) + +type family FirstOverlappingSlot + ( slots1 :: [ LocationSlot Nat ] ) -- ordered + ( slots2 :: [ LocationSlot Nat ] ) -- ordered + :: Maybe Overlap + where + FirstOverlappingSlot '[] _ = Nothing + FirstOverlappingSlot (slot1 ': slots1) slots2 + = If ( slot1 `Elem` slots2 ) + ( Just (OverlappingSlot slot1) ) + ( FirstOverlappingSlot slots1 slots2 ) + +type CompatibleSScalars + ( s1 :: SScalarTy ty1 ) + ( s2 :: SScalarTy ty2 ) + = ( CompatibleScalars ( ScalarFromSScalar s1 ) ( ScalarFromSScalar s2 ) :: Bool ) + +type family CompatibleScalars + ( s1 :: SPIRV.ScalarTy ) + ( s2 :: SPIRV.ScalarTy ) + :: Bool + where + CompatibleScalars ( SPIRV.Integer _ w ) ( SPIRV.Integer _ w ) = True + CompatibleScalars ( SPIRV.Floating w ) ( SPIRV.Floating w ) = True + CompatibleScalars _ _ = False + +-- | Simple enumeration of consecutive slots, +-- as many as the size of the type. +-- +-- Should not be used for compound types, +-- where the locations used are not necessarily consecutive. +type family EnumConsecutiveSlots + ( startLoc :: LocationSlot Nat ) + ( ty :: Type ) + :: [ LocationSlot Nat ] + where + EnumConsecutiveSlots loc ty + = EnumFromOfCount loc (Components ty) diff --git a/src/FIR/Validation/Pipeline.hs b/src/FIR/Validation/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/Pipeline.hs @@ -0,0 +1,746 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.Pipeline + +Validation of graphics pipelines at compile-time. + +This module validates graphics pipelines and computes information +necessary for the creation of a graphics pipeline in @Vulkan@. +-} + +module FIR.Validation.Pipeline where + +-- base +import Data.Kind + ( Type, Constraint ) +import Data.Type.Bool + ( type (&&) ) +import GHC.TypeLits + ( Symbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.Error + ( Assert ) +import Data.Type.Map + ( (:->)((:->)), Lookup ) +import Data.Type.Maybe + ( SequenceMaybe ) +import Data.Type.String + ( ShowNat ) +import {-# SOURCE #-} FIR.Pipeline + ( PrimitiveConnectedness(..), PrimitiveTopology(..) + , PipelineInfo(VertexInputInfo, Into) + , VertexLocationDescriptions, BindingStrides + ) +import FIR.ProgramState + ( ProgramState(ProgramState) + , TLInterface, TLInterfaceVariable + , EntryPointInfo(EntryPointInfo) + ) +import FIR.Validation.Arrayness + ( UnderlyingType ) +import qualified SPIRV.Decoration as SPIRV + ( Decoration(..) ) +import qualified SPIRV.Stage as SPIRV +import SPIRV.Stage + ( NamedShader ) +import qualified SPIRV.Storage as SPIRV + ( StorageClass(Input, Output) ) + +----------------------------------------------------------------------------------------- + +-- | Check that a pipeline is valid: +-- +-- - the first shader is a vertex shader, +-- - the last shader is a fragment shader, +-- - the ordering of the shaders is allowed, +-- - the interfaces between consecutive shaders match, +-- - the supplied primitive topology is valid. +type ValidPipelineInfo ( info :: PipelineInfo ) + = ( ValidPipelineInfoWithTopology info (GetTopologyInfo info) :: Constraint ) + +type ValidPipelineInfoWithTopology + ( info :: PipelineInfo ) + ( top :: PrimitiveTopology Nat ) + = ( ( StartsWithVertex info + , EndsWithFragment info + , MatchingInterfaces top info + , ValidTopology top + ) :: Constraint ) + +type family GetVertexInputInfo ( info :: PipelineInfo ) + :: ( PrimitiveTopology Nat, VertexLocationDescriptions, BindingStrides ) + where + GetVertexInputInfo + ( VertexInputInfo top descs strides ) = '( top, descs, strides ) + GetVertexInputInfo + ( pipe `Into` _ ) = GetVertexInputInfo pipe + +type family GetTopologyInfo ( info :: PipelineInfo ) :: PrimitiveTopology Nat where + GetTopologyInfo info = Proj31 (GetVertexInputInfo info) + +type family Proj31 ( p :: (a,b,c) ) :: a where + Proj31 '(a,_,_) = a + +-- | Check that a pipeline starts with a vertex shader. +type family StartsWithVertex ( info :: PipelineInfo ) :: Constraint where + StartsWithVertex + ( VertexInputInfo _ _ _ `Into` '( _, 'EntryPointInfo (_ :: SPIRV.ExecutionInfo Nat SPIRV.Vertex) _ _ ) ) + = () + StartsWithVertex ( info `Into` _ ) + = StartsWithVertex info + StartsWithVertex _ + = TypeError + ( Text "Pipeline does not begin with a vertex shader." ) + +-- | Check that a pipeline ends with a fragment shader. +type family EndsWithFragment ( info :: PipelineInfo ) :: Constraint where + EndsWithFragment + ( _ `Into` '( _, 'EntryPointInfo (_ :: SPIRV.ExecutionInfo Nat SPIRV.Fragment) _ _ ) ) + = () + EndsWithFragment _ + = TypeError + ( Text "Pipeline does not end with a fragment shader." ) + +-- | Check that the supplied primitive topology is valid. +type family ValidTopology (top :: PrimitiveTopology n) :: Constraint where + ValidTopology (Line Fan) + = TypeError ( Text "Invalid topology: fan of lines." ) + ValidTopology _ + = () + +----------------------------------------------------------------------------------------- +-- Validation of shader sequence / matching of interfaces. + +-- | Check that consecutive shaders in the pipeline match up correctly: +-- +-- - the sequence makes sense (e.g. can't have a tessellation shader following a geometry shader), +-- - the sequence is compatible with the supplied primitive topology, +-- - the interfaces match. +type family MatchingInterfaces + ( top :: PrimitiveTopology Nat ) + ( info :: PipelineInfo ) + :: Constraint where + MatchingInterfaces _ (VertexInputInfo _ _ _ ) = () + MatchingInterfaces _ (VertexInputInfo _ _ _ `Into` _) = () + MatchingInterfaces top + ( pipelineStages + `Into` pipelineStage1 + `Into` pipelineStage2 + ) + = ( ValidPipelineInterface top pipelineStage1 pipelineStage2 + , MatchingInterfaces top ( pipelineStages `Into` pipelineStage1 ) + ) + +--------------------------- +-- Sequencing of shaders. + +-- | Check that a given pair of shaders sequences correctly. +type family ValidPipelineInterface + ( top :: PrimitiveTopology Nat ) + ( stage1 :: (Symbol, EntryPointInfo) ) + ( stage2 :: (Symbol, EntryPointInfo) ) + :: Constraint + where + ValidPipelineInterface top + '( name1, + 'EntryPointInfo + ( 'SPIRV.ShaderExecutionInfo info1 + :: SPIRV.ExecutionInfo Nat ('SPIRV.Stage ('SPIRV.ShaderStage shader1)) + ) + ifaceVars1 + _ + ) + '( name2, + 'EntryPointInfo + ( 'SPIRV.ShaderExecutionInfo info2 + :: SPIRV.ExecutionInfo Nat ('SPIRV.Stage ('SPIRV.ShaderStage shader2)) + ) + ifaceVars2 + _ + ) + = ( MatchingInterface + name1 info1 ( SequenceMaybe ( Lookup SPIRV.Output ifaceVars1 ) ) + name2 info2 ( SequenceMaybe ( Lookup SPIRV.Input ifaceVars2 ) ) + , ValidSequence top + name1 shader1 info1 + name2 shader2 info2 + ) + +-- | Checks that the sequencing of shaders is valid. +-- +-- Checks that: +-- +-- - the sequence of stages is an allowed stage sequence, +-- e.g. a Geometry shader must be followed by a Fragment shader, +-- +-- - the stages fit the given primitive topology, +-- e.g. no tessellation shaders if primitive topology is not 'Patches', +-- +-- - subsequent stages are in the correct mode, +-- e.g. the Tessellation Evaluation shader outputs geometry +-- in the appropriate mode for the Geometry shader that follows. +type family ValidSequence + ( top :: PrimitiveTopology Nat ) + ( name1 :: Symbol ) + ( shader1 :: SPIRV.Shader ) + ( info1 :: SPIRV.ShaderInfo Nat shader1 ) + ( name2 :: Symbol ) + ( shader2 :: SPIRV.Shader ) + ( info2 :: SPIRV.ShaderInfo Nat shader2 ) + :: Constraint where + ValidSequence ('PatchesOfSize n) + _ SPIRV.VertexShader _ + _ SPIRV.TessellationControlShader _ + = () + ValidSequence top + _ SPIRV.VertexShader _ + _ SPIRV.TessellationControlShader _ + = TypeError + ( Text "Primitive topology is " :<>: ShowType top :<>: Text "," + :$$: Text "which cannot be used in the presence of tessellation shaders." + ) + ValidSequence ('PatchesOfSize n) + _ SPIRV.VertexShader _ + _ SPIRV.GeometryShader _ + = TypeError + ( Text "Primitive topology is 'Patches' – " + :<>: Text "which requires the use of tessellation – " + :$$: Text "but the supplied shader pipeline does not contain\ + \ any tessellation shaders." + ) + ValidSequence top + _ SPIRV.VertexShader _ + name2 SPIRV.GeometryShader geomInfo + = CompatibleGeometryTopology top 'Nothing name2 geomInfo + ValidSequence ('PatchesOfSize n) + _ SPIRV.VertexShader _ + _ SPIRV.FragmentShader _ + = TypeError + ( Text "Primitive topology is 'Patches' – " + :<>: Text "which requires the use of tessellation – " + :$$: Text "but the supplied shader pipeline does not contain\ + \ any tessellation shaders." + ) + ValidSequence _ + _ SPIRV.VertexShader _ + _ SPIRV.FragmentShader _ + = () + ValidSequence _ + name1 SPIRV.TessellationControlShader info1 + name2 SPIRV.TessellationEvaluationShader info2 + = CompatibleTessellationStages name1 info1 name2 info2 + ValidSequence top + name1 SPIRV.TessellationEvaluationShader info1 + name2 SPIRV.GeometryShader info2 + = CompatibleGeometryTopology top (Just '(name1, info1)) name2 info2 + ValidSequence _ + _ SPIRV.TessellationEvaluationShader _ + _ SPIRV.FragmentShader _ + = () + ValidSequence _ + _ SPIRV.GeometryShader _ + _ SPIRV.FragmentShader _ + = () + ValidSequence _ name1 shader1 _ name2 shader2 _ + = TypeError + ( Text "Invalid pipeline:" + :$$: Text (NamedShader name2 shader2) :<>: Text " cannot follow " + :<>: Text (NamedShader name1 shader1) :<>: Text "." + ) + +type family CompatibleGeometryTopology + ( top :: PrimitiveTopology Nat ) + ( mbTess :: Maybe + ( Symbol, SPIRV.ShaderInfo Nat SPIRV.TessellationEvaluationShader ) + ) + ( geomName :: Symbol ) + ( geom :: SPIRV.ShaderInfo Nat SPIRV.GeometryShader ) + :: Constraint + where + CompatibleGeometryTopology + ( 'PatchesOfSize n ) + ( 'Just '( teseName, SPIRV.TessellationEvaluationShaderInfo _ teseMode ) ) + geomName + ( SPIRV.GeometryShaderInfo _ geomMode ) + = ( CompatibleTessellationGeometryModes teseName teseMode geomName geomMode ) + CompatibleGeometryTopology + top + 'Nothing + geomName + ( SPIRV.GeometryShaderInfo _ geomMode ) + = ( CompatibleBasicGeometryTopology top geomName geomMode ) + + +-- | Check that the Geometry shader is getting the correct primitive topology, +-- in a pipeline without any tessellation. +type family CompatibleBasicGeometryTopology + ( top :: PrimitiveTopology Nat ) + ( geomName :: Symbol ) + ( geomMode :: SPIRV.GeometryInputMode ) + :: Constraint + where + CompatibleBasicGeometryTopology + Points + _ + SPIRV.InputModePoints + = () + CompatibleBasicGeometryTopology + (Line List) + _ + SPIRV.InputModeLines + = () + CompatibleBasicGeometryTopology + (Line AdjacencyStrip) + _ + SPIRV.InputModeLinesAdjacency + = () + CompatibleBasicGeometryTopology + (Triangle List) + _ + SPIRV.InputModeTriangles + = () + CompatibleBasicGeometryTopology + (Triangle Strip) + _ + SPIRV.InputModeTriangles + = () + CompatibleBasicGeometryTopology + (Triangle Fan) + _ + SPIRV.InputModeTriangles + = () + CompatibleBasicGeometryTopology + (Triangle AdjacencyList) + _ + SPIRV.InputModeTrianglesAdjacency + = () + CompatibleBasicGeometryTopology + (Triangle AdjacencyStrip) + _ + SPIRV.InputModeTrianglesAdjacency + = () + CompatibleBasicGeometryTopology + top + geomName + geomMode + = TypeError + ( Text (NamedShader geomName SPIRV.GeometryShader) + :<>: Text " input mode " :<>: Text (SPIRV.ShowGeometryInputMode geomMode) + :$$: Text "is incompatible with the primitive topology " + :<>: ShowType top :<>: Text "." + ) + +-- | Check that the Geometry shader is getting the correct primitive topology, +-- in a pipeline which does contain tessellation. +type family CompatibleTessellationGeometryModes + ( teseName :: Symbol ) + ( teseMode :: SPIRV.TessellationMode ) + ( geomName :: Symbol ) + ( geomMode :: SPIRV.GeometryInputMode ) + :: Constraint + where + CompatibleTessellationGeometryModes + _ SPIRV.ModePoints + _ SPIRV.InputModePoints + = () + CompatibleTessellationGeometryModes + _ SPIRV.ModeIsolines + _ SPIRV.InputModeLines + = () + CompatibleTessellationGeometryModes + _ SPIRV.ModeTriangles + _ SPIRV.InputModeTriangles + = () + CompatibleTessellationGeometryModes + _ SPIRV.ModeQuads + _ SPIRV.InputModeTriangles + = () + CompatibleTessellationGeometryModes + teseName teseMode + geomName geomMode + = TypeError + ( Text (NamedShader geomName SPIRV.GeometryShader) + :<>: Text " input mode " :<>: Text (SPIRV.ShowGeometryInputMode geomMode) + :$$: Text "is incompatible with the preceding " + :<>: Text (NamedShader teseName SPIRV.TessellationEvaluationShader) + :<>: Text " output mode " + :<>: Text (SPIRV.ShowTessellationMode teseMode) :<>: Text "." + ) + +-- | Check that the two tessellation stages are using the same tessellation mode. +type family CompatibleTessellationStages + ( tescName :: Symbol ) + ( tesc :: SPIRV.ShaderInfo Nat SPIRV.TessellationControlShader ) + ( teseName :: Symbol ) + ( tese :: SPIRV.ShaderInfo Nat SPIRV.TessellationEvaluationShader ) + :: Constraint + where + CompatibleTessellationStages + _ ( SPIRV.TessellationControlShaderInfo _ _ 'Nothing ) + _ ( SPIRV.TessellationEvaluationShaderInfo _ _ ) + = () + CompatibleTessellationStages + _ ( SPIRV.TessellationControlShaderInfo _ _ ('Just mode) ) + _ ( SPIRV.TessellationEvaluationShaderInfo _ mode ) + = () + CompatibleTessellationStages + tescName ( SPIRV.TessellationControlShaderInfo _ _ ('Just tescMode) ) + teseName ( SPIRV.TessellationEvaluationShaderInfo _ teseMode ) + = TypeError + ( Text "Conflicting tessellation modes:" + :$$: Text " - " :<>: Text (NamedShader tescName SPIRV.TessellationControlShader) + :<>: Text" specifies " + :<>: Text (SPIRV.ShowTessellationMode tescMode) :<>: Text "," + :$$: Text " - " :<>: Text (NamedShader teseName SPIRV.TessellationEvaluationShader) + :<>: Text" specifies " + :<>: Text (SPIRV.ShowTessellationMode teseMode) :<>: Text "." + ) + + +type family GetExecutionInfo + ( shader :: SPIRV.Shader ) + ( name :: Symbol ) + ( state :: ProgramState ) + :: SPIRV.ExecutionInfo Nat ('SPIRV.Stage ('SPIRV.ShaderStage shader)) + where + GetExecutionInfo shader name ('ProgramState _ _ _ _ eps _ _ _) + = GetExecutionInfoOf shader name eps + +type family GetExecutionInfoOf + ( shader :: SPIRV.Shader ) + ( name :: Symbol ) + ( eps :: [ Symbol :-> EntryPointInfo ] ) + :: SPIRV.ExecutionInfo Nat ('SPIRV.Stage ('SPIRV.ShaderStage shader)) + where + GetExecutionInfoOf shader name '[] + = TypeError + ( Text "Module does not define a " + :<>: Text (NamedShader name shader) + :<>: Text "." + ) + GetExecutionInfoOf shader name + ( ( name ':-> + ( 'EntryPointInfo + ( nfo :: SPIRV.ExecutionInfo Nat ('SPIRV.Stage ('SPIRV.ShaderStage shader)) ) + _ + _ + ) + ) + ': _ + ) + = nfo + GetExecutionInfoOf shader name ( _ ': eps ) + = GetExecutionInfoOf shader name eps + +type family GetInterface + ( shader :: SPIRV.Shader ) + ( name :: Symbol ) + ( state :: ProgramState ) + :: TLInterface + where + GetInterface shader name ('ProgramState _ _ _ _ eps _ _ _) + = GetInterfaceOf shader name eps + +type family GetInterfaceOf + ( shader :: SPIRV.Shader ) + ( name :: Symbol ) + ( eps :: [ Symbol :-> EntryPointInfo ] ) + :: TLInterface + where + GetInterfaceOf shader name '[] + = TypeError + ( Text "Module does not define a " + :<>: Text (NamedShader name shader) + :<>: Text "." + ) + GetInterfaceOf shader name + ( ( name ':-> + ( 'EntryPointInfo + _ + iface + _ + ) + ) + ': _ + ) + = iface + GetInterfaceOf shader name ( _ ': eps ) + = GetInterfaceOf shader name eps + +--------------------------- +-- Interface matching. + +type family MatchingInterface + ( stageName1 :: Symbol ) + ( stageInfo1 :: SPIRV.ShaderInfo Nat stage1 ) + ( outputs :: [Symbol :-> TLInterfaceVariable] ) + ( stageName2 :: Symbol ) + ( stageInfo2 :: SPIRV.ShaderInfo Nat stage2 ) + ( inputs :: [Symbol :-> TLInterfaceVariable] ) + :: Constraint + where + MatchingInterface + _ _ '[] + _ _ '[] + = () + MatchingInterface + stageName1 ( stageInfo1 :: SPIRV.ShaderInfo Nat stage1 ) '[] + stageName2 ( stageInfo2 :: SPIRV.ShaderInfo Nat stage2 ) ( ( inputName ':-> '(_, ty2) ) ': _ ) + = TypeError + ( Text "Input " :<>: ShowType inputName + :<>: Text " of type " :<>: ShowType ty2 + :<>: Text " of " :<>: Text ( NamedShader stageName1 stage2 ) :<>: Text "," + :$$: Text "does not match any output of " + :<>: Text (NamedShader stageName2 stage1) :<>: Text "." + ) + MatchingInterface + stageName1 stageInfo1 ( ( outputName ':-> output ) ': outputs ) + stageName2 stageInfo2 inputs + = MatchingInterface + stageName1 stageInfo1 outputs + stageName2 stageInfo2 + ( RemoveMatch + stageName1 stageInfo1 outputName output + stageName2 stageInfo2 inputs + ) + +type family RemoveMatch + ( stageName1 :: Symbol ) + ( stageInfo1 :: SPIRV.ShaderInfo Nat stage1 ) + ( outputName :: Symbol ) + ( output :: TLInterfaceVariable ) + ( stageName2 :: Symbol ) + ( stageInfo2 :: SPIRV.ShaderInfo Nat stage2 ) + ( inputs :: [ Symbol :-> TLInterfaceVariable] ) + :: [ Symbol :-> TLInterfaceVariable] + where + RemoveMatch + stageName1 ( stageInfo1 :: SPIRV.ShaderInfo Nat stage1 ) outputName '(_, ty1) + stageName2 ( stageInfo2 :: SPIRV.ShaderInfo Nat stage2 ) '[] + = TypeError + ( Text "Output " :<>: ShowType outputName + :<>: Text " of type " :<>: ShowType ty1 + :<>: Text " of " :<>: Text ( NamedShader stageName1 stage1 ) :<>: Text "," + :$$: Text "does not match any input of " + :<>: Text (NamedShader stageName2 stage2) :<>: Text "." + ) + RemoveMatch + stageName1 stageInfo1 outputName '(decs1, ty1) + stageName2 stageInfo2 ( ( inputName ':-> '(decs2, ty2) ) ': inputs ) + = RemoveThisMatchOrContinue + ( SameLocation + (Location decs1) (Component decs1) + (Location decs2) (Component decs2) + ) + stageName1 stageInfo1 outputName '(decs1, ty1) + stageName2 stageInfo2 inputName '(decs2, ty2) + inputs + +type family RemoveThisMatchOrContinue + ( mbLocation :: Maybe (Nat, Nat) ) + ( stageName1 :: Symbol ) + ( stageInfo1 :: SPIRV.ShaderInfo Nat shader1 ) + ( outputName :: Symbol ) + ( output :: TLInterfaceVariable ) + ( stageName2 :: Symbol ) + ( stageInfo2 :: SPIRV.ShaderInfo Nat shader2 ) + ( inputName :: Symbol ) + ( input :: TLInterfaceVariable ) + ( inputs :: [ Symbol :-> TLInterfaceVariable] ) + :: [ Symbol :-> TLInterfaceVariable ] + where + RemoveThisMatchOrContinue (Just loc) + stageName1 stageInfo1 outputName output + stageName2 stageInfo2 inputName input inputs + = Assert + ( Matches loc + stageName1 stageInfo1 outputName output + stageName2 stageInfo2 inputName input + ) + inputs + RemoveThisMatchOrContinue Nothing + stageName1 stageInfo1 outputName output + stageName2 stageInfo2 inputName input inputs + = ( inputName ':-> input ) ': + RemoveMatch + stageName1 stageInfo1 outputName output + stageName2 stageInfo2 inputs + +type family Matches + ( location :: (Nat,Nat) ) + ( stageName1 :: Symbol ) + ( stage1 :: SPIRV.ShaderInfo Nat shader1 ) + ( outputName :: Symbol ) + ( output :: TLInterfaceVariable ) + ( stageName2 :: Symbol ) + ( stage2 :: SPIRV.ShaderInfo Nat shader2 ) + ( inputName :: Symbol ) + ( input :: TLInterfaceVariable ) + :: Bool + where + Matches loc + stageName1 ( stageInfo1 :: SPIRV.ShaderInfo Nat stage1 ) + outputName '(decs1, ty1) + stageName2 ( stageInfo2 :: SPIRV.ShaderInfo Nat stage2 ) + inputName '(decs2, ty2) + = MatchingUnderlyingTypes loc + stageName1 stage1 + outputName + ( UnderlyingType outputName SPIRV.Output decs1 stageName1 ty1 + ( SPIRV.ShaderExecutionInfo stageInfo1 ) + ) + stageName2 stage2 + inputName + ( UnderlyingType inputName SPIRV.Input decs2 stageName2 ty2 + ( SPIRV.ShaderExecutionInfo stageInfo2 ) + ) + && MatchingDecorations loc + stageName1 stage1 outputName decs1 + stageName2 stage2 inputName decs2 + +type family SameLocation + ( loc1 :: Maybe Nat ) + ( comp1 :: Nat ) + ( loc2 :: Maybe Nat ) + ( comp2 :: Nat ) + :: Maybe (Nat, Nat) + where + SameLocation (Just loc) comp (Just loc) comp + = Just '(loc, comp) + SameLocation _ _ _ _ + = Nothing + +type family Location (decs :: [SPIRV.Decoration Nat]) :: Maybe Nat where + Location ('SPIRV.Location i ': _) + = Just i + Location (_ ': decs) + = Location decs + Location '[] + = Nothing + +type family Component (decs :: [SPIRV.Decoration Nat]) :: Nat where + Component ('SPIRV.Component i ': _) = i + Component (_ ': decs) = Component decs + Component '[] = 0 + +type family MatchingUnderlyingTypes + ( loc :: (Nat, Nat) ) + ( stageName1 :: Symbol ) + ( stage1 :: SPIRV.Shader ) + ( varName1 :: Symbol ) + ( u_type1 :: Type ) + ( stageName2 :: Symbol ) + ( stage2 :: SPIRV.Shader ) + ( varName2 :: Symbol ) + ( u_type2 :: Type ) + :: Bool + where + MatchingUnderlyingTypes _ + _ _ _ u_ty1 + _ _ _ u_ty1 + = 'True + MatchingUnderlyingTypes loc + stageName1 stage1 varName1 u_ty1 + stageName2 stage2 varName2 u_ty2 + = TypeError + ( MismatchLocation loc + :$$: Text "Output named " :<>: ShowType varName1 + :<>: Text " of " :<>: Text (NamedShader stageName1 stage1) + :<>: Text " has underlying type " :<>: ShowType u_ty1 :<>: Text "," + :$$: Text "whereas input named " :<>: ShowType varName2 + :<>: Text " of " :<>: Text (NamedShader stageName2 stage2) + :<>: Text " has underlying type " :<>: ShowType u_ty2 :<>: Text "." + ) + +type family MismatchLocation ( loc :: (Nat,Nat) ) :: ErrorMessage where + MismatchLocation '(loc, 0) + = Text "Interface mismatch at location " :<>: Text (ShowNat loc) + :<>: Text "." + MismatchLocation '(loc, comp) + = Text "Interface mismatch at location " :<>: Text (ShowNat loc) + :<>: Text ", component " :<>: Text (ShowNat loc) :<>: Text "." + +type family MatchingDecorations + ( loc :: (Nat, Nat) ) + ( stageName1 :: Symbol ) + ( stage1 :: SPIRV.Shader ) + ( inputName :: Symbol ) + ( decs1 :: [SPIRV.Decoration Nat] ) + ( stageName2 :: Symbol ) + ( stage2 :: SPIRV.Shader ) + ( outputName :: Symbol ) + ( decs2 :: [SPIRV.Decoration Nat] ) + :: Bool + where + MatchingDecorations _ + _ _ _ '[] + _ _ _ '[] + = 'True + MatchingDecorations loc + stageName1 stage1 outputName '[] + stageName2 stage2 inputName (dec2 ': _) + = TypeError + ( MismatchLocation loc + :$$: Text "Input named " :<>: ShowType inputName + :<>: Text " to " :<>: Text (NamedShader stageName2 stage2) + :<>: Text " is decorated with " :<>: ShowType dec2 :<>: Text "," + :$$: Text "but matching output " :<>: ShowType outputName + :<>: Text " to " :<>: Text (NamedShader stageName1 stage1) + :<>: Text " is missing such a decoration." + ) + MatchingDecorations loc + stageName1 stage1 outputName ( dec1 ': decs1 ) + stageName2 stage2 inputName decs2 + = MatchingDecorations loc + stageName1 stage1 outputName decs1 + stageName2 stage2 inputName + ( FindAndRemoveDecoration loc + stageName1 stage1 outputName dec1 + stageName2 stage2 inputName decs2 + ) + +type family FindAndRemoveDecoration + ( loc :: (Nat, Nat) ) + ( stageName1 :: Symbol ) + ( stage1 :: SPIRV.Shader ) + ( outputName :: Symbol ) + ( dec1 :: SPIRV.Decoration Nat ) + ( stageName2 :: Symbol ) + ( stage2 :: SPIRV.Shader ) + ( inputName :: Symbol ) + ( decs2 :: [SPIRV.Decoration Nat] ) + :: [SPIRV.Decoration Nat] + where + FindAndRemoveDecoration _ + _ _ _ dec1 + _ _ _ (dec1 ': decs2) + = decs2 + FindAndRemoveDecoration loc + stageName1 stage1 outputName dec1 + stageName2 stage2 inputName (dec2 ': decs2) + = dec2 ': FindAndRemoveDecoration loc + stageName1 stage1 outputName dec1 + stageName2 stage2 inputName decs2 + FindAndRemoveDecoration loc + stageName1 stage1 outputName dec1 + stageName2 stage2 inputName '[] + = TypeError + ( MismatchLocation loc + :$$: Text "Output named " :<>: ShowType outputName + :<>: Text " to " :<>: Text (NamedShader stageName1 stage1) + :<>: Text " is decorated with " :<>: ShowType dec1 :<>: Text "," + :$$: Text "but matching input " :<>: ShowType inputName + :<>: Text " to " :<>: Text (NamedShader stageName2 stage2) + :<>: Text " is missing such a decoration." + ) diff --git a/src/FIR/Validation/RayTracing.hs b/src/FIR/Validation/RayTracing.hs new file mode 100644 --- /dev/null +++ b/src/FIR/Validation/RayTracing.hs @@ -0,0 +1,459 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: FIR.Validation.RayTracing + +Validation of ray-tracing and ray-query operations. +-} + + +module FIR.Validation.RayTracing + ( -- * Ray tracing validation + CanTraceRay, CanExecuteCallable + -- * Ray query validation + -- ** Modifying ray query state + , NewRayQuery, RayQueryProceed, RayQueryCandidateState, RayQueryCommittedState, Terminate + -- ** Validating ray query state + , CanGenerateIntersection, CanConfirmIntersection + , HasRayQuery, CanGetIntersectionT, HasSomeIntersection, HasSomeTriangleIntersection + ) + where + +-- base +import Data.Kind + ( Type, Constraint ) +import Data.Type.Bool + ( If ) +import GHC.TypeLits + ( Symbol + , TypeError, ErrorMessage(..) + ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Type.Error + ( Try ) +import Data.Type.Map + ( (:->)((:->)), Insert, LookupAndLookup ) +import Data.Type.Maybe + ( IfNothingThen ) +import FIR.Prim.RayTracing + ( RayQueryState(..), RayQueryProceedState(..) + , IntersectionType(..), RayQueryCandidateIntersection(..), RayQueryCommittedIntersection(..) + ) +import FIR.ProgramState + ( ProgramState(..), FunctionContext(..) + , TLInterfaceVariable + ) +import qualified SPIRV.Stage as SPIRV +import qualified SPIRV.Storage as SPIRV + +-------------------------------------------------------------------------- +-- Ray tracing validation. + +-- | Check that a 'traceRay' instruction is valid: +-- +-- - the execution model is a ray generation, closest hit or miss shader, +-- - @payload@ indeed refers to a variable with ray payload storage class. +type family CanTraceRay + ( payload :: Symbol ) + ( i :: ProgramState ) + :: Constraint + where + CanTraceRay payload + ( 'ProgramState + _ + ('InEntryPoint _ + ( info :: SPIRV.ExecutionInfo Nat ( 'SPIRV.Stage ( 'SPIRV.RayStage shader ) ) ) + _ + ) + _ _ _ iface _ _ + ) = If ( StageIsCompatibleWithRayPayload shader ) + ( HasRayPayloadBinding payload + ( IfNothingThen + ( LookupAndLookup ('SPIRV.RayStorage (SPIRV.RayPayload SPIRV.Incoming)) payload iface ) + ( LookupAndLookup ('SPIRV.RayStorage (SPIRV.RayPayload SPIRV.Lifetime)) payload iface ) + ) + ) + ( TypeError + ( Text "'traceRay' instruction not allowed in ray-tracing shader " + :<>: Text ( SPIRV.StageName ( 'SPIRV.RayStage shader ) ) + :<>: Text "." + ) + ) + CanTraceRay _ _ = TypeError + ( Text "Cannot call 'traceRay' here: not within a ray-tracing shader." ) + +type family StageIsCompatibleWithRayPayload ( shader :: SPIRV.RayShader ) :: Bool where + StageIsCompatibleWithRayPayload SPIRV.RayGenerationShader = 'True + StageIsCompatibleWithRayPayload SPIRV.ClosestHitShader = 'True + StageIsCompatibleWithRayPayload SPIRV.MissShader = 'True + StageIsCompatibleWithRayPayload _ = 'False + + +type family HasRayPayloadBinding + ( callable :: Symbol ) + ( mbVar :: Maybe TLInterfaceVariable ) + :: Constraint + where + HasRayPayloadBinding payload 'Nothing = + TypeError + ( Text "Cannot use payload named " :<>: ShowType payload :<>: Text " in this call to 'traceRay'." + :$$: Text "No interface variable with 'RayPayload' storage class could be found with this name." + ) + HasRayPayloadBinding payload ( 'Just '( decs, ty ) ) = + Try + ( ValidPayloadType payload ty ) + +{- +type family PayloadLocation ( payload :: Symbol ) ( decs :: [ SPIRV.Decoration Nat ] ) :: Either ErrorMessage Constraint where + PayloadLocation payload '[] = Left + ( Text "Ray payload interface variable named " :<>: ShowType payload + :$$: Text "is missing a 'Location' decoration." + ) + PayloadLocation _ ( SPIRV.Location _ ': _ ) = Right ( () :: Constraint ) + PayloadLocation payload ( _ ': decs ) = PayloadLocation payload decs +-} + +type family ValidPayloadType ( payload :: Symbol ) ( ty :: Type ) :: Either ErrorMessage Constraint where + ValidPayloadType _ _ = Right ( () :: Constraint ) -- TODO + + +-- | Check that an 'executeCallable' instruction is valid: +-- +-- - the execution model is a ray generation, closest hit, miss shader or callable shader, +-- - @callableData@ indeed refers to a variable with callable data storage class. +type family CanExecuteCallable + ( callableData :: Symbol ) + ( i :: ProgramState ) + :: Constraint + where + CanExecuteCallable callable + ( 'ProgramState + _ + ('InEntryPoint _ + ( info :: SPIRV.ExecutionInfo Nat ( 'SPIRV.Stage ( 'SPIRV.RayStage shader ) ) ) + _ + ) + _ _ _ iface _ _ + ) = If ( StageIsCompatibleWithCallableData shader ) + ( HasCallableDataBinding callable + ( IfNothingThen + ( LookupAndLookup ('SPIRV.RayStorage (SPIRV.CallableData SPIRV.Incoming)) callable iface ) + ( LookupAndLookup ('SPIRV.RayStorage (SPIRV.CallableData SPIRV.Lifetime)) callable iface ) + ) + ) + ( TypeError + ( Text "'executeCallable' instruction not allowed in ray-tracing shader " + :<>: Text ( SPIRV.StageName ( 'SPIRV.RayStage shader ) ) + :<>: Text "." + ) + ) + CanExecuteCallable _ _ = TypeError + ( Text "Cannot call 'executeCallable' here: not within a ray-tracing shader." ) + +type family StageIsCompatibleWithCallableData ( shader :: SPIRV.RayShader ) :: Bool where + StageIsCompatibleWithCallableData SPIRV.RayGenerationShader = 'True + StageIsCompatibleWithCallableData SPIRV.ClosestHitShader = 'True + StageIsCompatibleWithCallableData SPIRV.MissShader = 'True + StageIsCompatibleWithCallableData SPIRV.CallableShader = 'True + StageIsCompatibleWithCallableData _ = 'False + +type family HasCallableDataBinding + ( callable :: Symbol ) + ( bd :: Maybe TLInterfaceVariable ) + :: Constraint + where + HasCallableDataBinding callable 'Nothing = + TypeError + ( Text "Cannot use callable data named " :<>: ShowType callable :<>: Text " in this call to 'executeCallable'." + :$$: Text "No interface variable with 'CallableData' storage class could be found with this name." + ) + HasCallableDataBinding callable ( 'Just '( decs, ty ) ) = + Try + ( ValidCallableDataType callable ty ) + +{- +type family CallableDataLocation ( payload :: Symbol ) ( decs :: [ SPIRV.Decoration Nat ] ) :: Either ErrorMessage Constraint where + CallableDataLocation callable '[] = Left + ( Text "Callable data interface variable named " :<>: ShowType callable + :$$: Text "is missing a 'Location' decoration." + ) + CallableDataLocation _ ( SPIRV.Location _ ': _ ) = Right ( () :: Constraint ) + CallableDataLocation callable ( _ ': decs ) = CallableDataLocation callable decs +-} + +type family ValidCallableDataType ( callable :: Symbol ) ( ty :: Type ) :: Either ErrorMessage Constraint where + ValidCallableDataType _ _ = Right ( () :: Constraint ) -- TODO + + +-------------------------------------------------------------------------- +-- Ray query validation. + +-- | Start a new ray query. +type family NewRayQuery ( rayQuery :: Symbol ) ( i :: ProgramState ) :: ProgramState where + NewRayQuery rayQuery ( 'ProgramState bds ctx cfg fns eps iface rayQueries bk ) = + 'ProgramState bds ctx cfg fns eps iface ( Insert rayQuery ( 'RayQueryState 'Nothing 'Nothing ) rayQueries ) bk + +-- | Validation for ray query 'ifProceeding' function: +-- +-- - check that the ray query referred to has been initialized, +-- - check that the ray query has not already completed +-- - sets the ray query proceed state going forwards. +type family RayQueryProceed + ( rayQuery :: Symbol ) + ( st :: RayQueryProceedState ) + ( i :: ProgramState ) + :: ProgramState where + RayQueryProceed rayQuery st ( 'ProgramState bds ctx cfg fns eps iface rayQueries bk ) = + 'ProgramState bds ctx cfg fns eps iface ( SetProceedState rayQuery st rayQueries) bk + +type family SetProceedState + ( rayQuery :: Symbol ) + ( st :: RayQueryProceedState ) + ( rayQueries :: [ Symbol :-> RayQueryState ] ) + :: [ Symbol :-> RayQueryState ] + where + SetProceedState rayQuery _ '[] = + TypeError + ( Text "'ifProceeding': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." ) + SetProceedState rayQuery st ( ( rayQuery ':-> 'RayQueryState ( 'Just Complete ) _ ) ': _ ) = + TypeError + ( Text "'ifProceeding': cannot proceed with ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as this ray query has already completed." + ) + SetProceedState rayQuery st ( ( rayQuery ':-> 'RayQueryState _ commState ) ': rayQueries ) = + ( rayQuery ':-> 'RayQueryState ( 'Just st ) commState ) ': rayQueries + SetProceedState rayQuery st ( otherRayQuery ': rayQueries ) + = otherRayQuery ': SetProceedState rayQuery st rayQueries + +-- | Validation for ray query 'withCandidateIntersection' function: +-- +-- - check that the ray query referred to has been initialized, +-- - check that the ray query has not already completed, +-- - sets the candidate intersection type going forwards. +type family RayQueryCandidateState + ( rayQuery :: Symbol ) + ( st :: RayQueryCandidateIntersection ) + ( i :: ProgramState ) + :: ProgramState where + RayQueryCandidateState rayQuery st ( 'ProgramState bds ctx cfg fns eps iface rayQueries bk ) = + 'ProgramState bds ctx cfg fns eps iface ( SetCandidateState rayQuery st rayQueries) bk + +type family SetCandidateState + ( rayQuery :: Symbol ) + ( st :: RayQueryCandidateIntersection ) + ( rayQueries :: [ Symbol :-> RayQueryState ] ) + :: [ Symbol :-> RayQueryState ] + where + SetCandidateState rayQuery _ '[] = + TypeError + ( Text "'withCandidateIntersection': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." ) + SetCandidateState rayQuery st ( ( rayQuery ':-> 'RayQueryState 'Nothing _ ) ': _ ) = + TypeError + ( Text "'withCandidateIntersection': cannot get candidate intersection type for ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as it has not been decided whether to proceed with this ray query." + :$$: Text "Possible fix: use 'ifProceeding' to determine whether ray query proceeds." + ) + SetCandidateState rayQuery st ( ( rayQuery ':-> 'RayQueryState ( 'Just Complete ) _ ) ': _ ) = + TypeError + ( Text "'withCandidateIntersection': cannot get candidate intersection type for ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as this ray query has already completed." + ) + SetCandidateState rayQuery st ( ( rayQuery ':-> 'RayQueryState _ commState ) ': rayQueries ) = + ( rayQuery ':-> 'RayQueryState ( 'Just ( Incomplete ( 'Just st ) ) ) commState ) ': rayQueries + SetCandidateState rayQuery st ( otherRayQuery ': rayQueries ) + = otherRayQuery ': SetCandidateState rayQuery st rayQueries + +-- | Validation for ray query 'withCommittedIntersection' function: +-- +-- - check that the ray query referred to has been initialized, +-- - sets the committed intersection type going forwards. +type family RayQueryCommittedState + ( rayQuery :: Symbol ) + ( st :: RayQueryCommittedIntersection ) + ( i :: ProgramState ) + :: ProgramState where + RayQueryCommittedState rayQuery st ( 'ProgramState bds ctx cfg fns eps iface rayQueries bk ) = + 'ProgramState bds ctx cfg fns eps iface ( SetCommittedState rayQuery st rayQueries) bk + +type family SetCommittedState + ( rayQuery :: Symbol ) + ( st :: RayQueryCommittedIntersection ) + ( rayQueries :: [ Symbol :-> RayQueryState ] ) + :: [ Symbol :-> RayQueryState ] + where + SetCommittedState rayQuery _ '[] = + TypeError + ( Text "'withCommittedIntersection': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." ) + SetCommittedState rayQuery st ( ( rayQuery ':-> 'RayQueryState procState _ ) ': rayQueries ) = + ( rayQuery ':-> 'RayQueryState procState ( 'Just st ) ) ': rayQueries + SetCommittedState rayQuery st ( otherRayQuery ': rayQueries ) + = otherRayQuery ': SetCommittedState rayQuery st rayQueries + +-- | Validation for ray query 'terminate' instruction. +-- +-- - check that the ray query referred to has already been initialized, +-- - set it to completed state. +type family Terminate + ( rayQuery :: Symbol ) + ( i :: ProgramState ) + :: ProgramState where + Terminate rayQuery ( 'ProgramState bds ctx cfg fns eps iface rayQueries bk ) = + 'ProgramState bds ctx cfg fns eps iface ( TerminateRayQuery rayQuery rayQueries) bk + +type family TerminateRayQuery + ( rayQuery :: Symbol ) + ( rayQueries :: [ Symbol :-> RayQueryState ] ) + :: [ Symbol :-> RayQueryState ] + where + TerminateRayQuery rayQuery '[] = + TypeError + ( Text "'terminate': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." ) + TerminateRayQuery rayQuery ( ( rayQuery ':-> 'RayQueryState ( 'Just Complete ) _ ) ': _ ) = + TypeError + ( Text "'terminate': cannot terminate ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as it has already completed." + ) + TerminateRayQuery rayQuery ( ( rayQuery ':-> 'RayQueryState _ comm ) ': rayQueries ) = + ( rayQuery ':-> 'RayQueryState ( 'Just 'Complete ) comm ) ': rayQueries + TerminateRayQuery rayQuery ( otherRayQuery ': rayQueries ) + = otherRayQuery ': TerminateRayQuery rayQuery rayQueries + + +-- | Validation for ray query "generateIntersection": +-- +-- - check that the ray query referred to has already been initialized, +-- - check that we have a candidate AABB intersection. +type family CanGenerateIntersection ( rayQuery :: Symbol ) ( lk :: Maybe RayQueryState ) :: Constraint where + CanGenerateIntersection rayQuery 'Nothing = TypeError + ( Text "'generateIntersection': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." ) + CanGenerateIntersection _ ( Just ( 'RayQueryState ( 'Just ( 'Incomplete ( 'Just AABBCandidateIntersection ) ) ) _ ) ) = ( () :: Constraint ) + CanGenerateIntersection rayQuery _ = TypeError + ( Text "'generateIntersection' cannot be called here on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as the candidate intersection type is not known to be an AABB." + :$$: Text "Possible fix: use 'withCandidateIntersection' to determine candidate intersection type." + ) + +-- | Validation for ray query "confirmIntersection": +-- +-- - check that the ray query referred to has already been initialized, +-- - check that we have a candidate triangle intersection. +type family CanConfirmIntersection ( rayQuery :: Symbol ) ( lk :: Maybe RayQueryState ) :: Constraint where + CanConfirmIntersection rayQuery 'Nothing = TypeError + ( Text "'confirmIntersection': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." ) + CanConfirmIntersection _ ( Just ( 'RayQueryState ( 'Just ( 'Incomplete ( 'Just TriangleCandidateIntersection ) ) ) _ ) ) = ( () :: Constraint ) + CanConfirmIntersection rayQuery _ = TypeError + ( Text "'confirmIntersection' cannot be called here on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as the candidate intersection type is not known to be a triangle." + :$$: Text "Possible fix: use 'withCandidateIntersection' to determine candidate intersection type." + ) + +-- | Check that a given ray query name has been initialised. +type family HasRayQuery ( callerName :: Symbol ) ( rayQuery :: Symbol ) ( lk :: Maybe RayQueryState ) :: Constraint where + HasRayQuery callerName rayQuery 'Nothing = TypeError + ( ShowType callerName :<>: Text ": no ray query found with name " :<>: ShowType rayQuery :<>: Text "." ) + HasRayQuery _ _ _ = ( () :: Constraint ) + +-- | Validation for ray query 'getIntersectionT': +-- +-- - check that the ray query referred to has already been initialized, +-- - for a candidate intersection, check that we have a candidate triangle intersection, +-- - for a committed intersection, check that we have some committed intersection. +type family CanGetIntersectionT ( rayQuery :: Symbol ) ( interTy :: IntersectionType ) ( lk :: Maybe RayQueryState ) :: Constraint where + CanGetIntersectionT rayQuery _ Nothing = TypeError + ( Text "'getIntersectionT': no ray query found with name " :<>: ShowType rayQuery :<>: Text "." ) + CanGetIntersectionT rayQuery Candidate ( Just ( 'RayQueryState ( 'Just ( 'Incomplete _ ) ) _ ) ) = ( () :: Constraint ) + CanGetIntersectionT rayQuery Candidate _ = TypeError + ( Text "'getIntersectionT' cannot be called here with a 'Candidate' intersection type" + :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as it has not been decided whether to proceed with this ray query." + :$$: Text "Possible fix: use 'ifProceeding' to determine whether ray query proceeds." + ) + CanGetIntersectionT rayQuery Committed ( Just ( 'RayQueryState _ Nothing ) ) = TypeError + ( Text "'getIntersectionT' cannot be called here with a 'Committed' intersection type" + :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as the committed intersection type has not been determined." + :$$: Text "Possible fix: use 'withCommittedIntersection' to determine committed intersection type." + ) + CanGetIntersectionT rayQuery Committed ( Just ( 'RayQueryState _ ( Just NoIntersection ) ) ) = TypeError + ( Text "'getIntersectionT' cannot be called here with a 'Committed' intersection type" + :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as there is no currently 'Committed' intersection type." + ) + CanGetIntersectionT rayQuery Committed _ = ( () :: Constraint ) + +-- | Check that an intersection has occurred in the ray query state. +type family HasSomeIntersection + ( callerName :: Symbol ) + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( lk :: Maybe RayQueryState ) + :: Constraint where + HasSomeIntersection callerName rayQuery _ 'Nothing = TypeError + ( ShowType callerName :<>: Text ": no ray query found with name " :<>: ShowType rayQuery :<>: Text "." ) + HasSomeIntersection callerName rayQuery Candidate ( 'Just ( 'RayQueryState ( 'Just ( 'Incomplete _ ) ) _ ) ) = ( () :: Constraint ) + HasSomeIntersection callerName rayQuery Candidate _ = TypeError + ( ShowType callerName :<>: Text " cannot be called here with a 'Candidate' intersection type" + :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as it has not been decided whether to proceed with this ray query." + :$$: Text "Possible fix: use 'ifProceeding' to determine whether ray query proceeds." + ) + HasSomeIntersection callerName rayQuery Committed ( Just ( 'RayQueryState _ Nothing ) ) = TypeError + ( ShowType callerName :<>: Text " cannot be called here with a 'Committed' intersection type" + :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as the committed intersection type has not been determined." + :$$: Text "Possible fix: use 'withCommittedIntersection' to determine committed intersection type." + ) + HasSomeIntersection callerName rayQuery Committed ( Just ( 'RayQueryState _ ( Just NoIntersection ) ) ) = TypeError + ( ShowType callerName :<>: Text " cannot be called here with a 'Committed' intersection type" + :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as there is no currently 'Committed' intersection type." + ) + HasSomeIntersection _ _ Committed _ = ( () :: Constraint ) + +-- | Check that a triangle intersection has occurred in the ray query state. +type family HasSomeTriangleIntersection + ( callerName :: Symbol ) + ( rayQuery :: Symbol ) + ( interTy :: IntersectionType ) + ( lk :: Maybe RayQueryState ) + :: Constraint where + HasSomeTriangleIntersection callerName rayQuery _ 'Nothing = TypeError + ( ShowType callerName :<>: Text ": no ray query found with name " :<>: ShowType rayQuery :<>: Text "." ) + HasSomeTriangleIntersection callerName rayQuery Candidate ( 'Just ( 'RayQueryState 'Nothing _ ) ) = TypeError + ( ShowType callerName :<>: Text " cannot be called here with a 'Candidate' intersection type" + :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as it has not been decided whether to proceed with this ray query." + :$$: Text "Possible fix: use 'ifProceeding' to determine whether ray query proceeds." + ) + HasSomeTriangleIntersection callerName rayQuery Candidate ( 'Just ( 'RayQueryState ( 'Just ( 'Incomplete 'Nothing ) ) _ ) ) = TypeError + ( ShowType callerName :<>: Text " cannot be called here with a 'Candidate' intersection type" + :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as the candidate intersection type has not been determined." + :$$: Text "Possible fix: use 'withCandidateIntersection' to determine candidate intersection type." + ) + HasSomeTriangleIntersection callerName rayQuery Candidate ( 'Just ( 'RayQueryState ( 'Just ( 'Incomplete ( 'Just TriangleCandidateIntersection ) ) ) _ ) ) = + ( () :: Constraint ) + HasSomeTriangleIntersection callerName rayQuery Candidate _ = TypeError + ( ShowType callerName :<>: Text " cannot be called here with a 'Candidate' intersection type" + :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as the candidate intersection type is not 'Triangle'." + ) + HasSomeTriangleIntersection callerName rayQuery Committed ( Just ( 'RayQueryState _ Nothing ) ) = TypeError + ( ShowType callerName :<>: Text " cannot be called here with a 'Committed' intersection type" + :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as the committed intersection type has not been determined." + :$$: Text "Possible fix: use 'withCommittedIntersection' to determine committed intersection type." + ) + HasSomeTriangleIntersection _ _ Committed ( Just ( 'RayQueryState _ ( Just TriangleIntersection ) ) ) = ( () :: Constraint ) + HasSomeTriangleIntersection callerName rayQuery Committed ( Just ( 'RayQueryState _ ( Just NoIntersection ) ) ) = TypeError + ( ShowType callerName :<>: Text " cannot be called here with a 'Committed' intersection type" + :$$: Text "on ray query named " :<>: ShowType rayQuery :<>: Text "," + :$$: Text "as the committed intersection type is not 'Triangle'." + ) diff --git a/src/Instances/TH/Lift.hs b/src/Instances/TH/Lift.hs new file mode 100644 --- /dev/null +++ b/src/Instances/TH/Lift.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module: Instances.TH.Lift + +Some Template Haskell 'Lift' instances required by this library. +-} + +module Instances.TH.Lift where + +#if !MIN_VERSION_containers(0,6,6) + +-- template-haskell +import Language.Haskell.TH.Syntax + ( Lift(..) ) + +-- containers +import Data.Set + ( Set ) +import qualified Data.Set as Set + ( fromList, toList ) + + +instance (Ord a, Lift a) => Lift (Set a) where + lift t = [| Set.fromList $(lift $ Set.toList t) |] +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped t = [|| Set.fromList $$(liftTyped $ Set.toList t) ||] +#endif + +#endif diff --git a/src/Math/Algebra/Class.hs b/src/Math/Algebra/Class.hs new file mode 100644 --- /dev/null +++ b/src/Math/Algebra/Class.hs @@ -0,0 +1,695 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Math.Algebra.Class + +Alternative numeric hierarchy, tailored for this library. + +The main problem with the standard numeric hierarchy consists +of class methods with monomorphic return types. + +For instance, the method + +> toInteger :: Integral a => a -> Integer + +is not amenable to overloading when working with ASTs, as +given e.g. @AST Int@ there is no way of recovering an @Integer@. + +Contrast this with a method such as + +> fromInteger :: Num a => Integer -> a + +There is no problem instantiating this method at a type such as @AST Int@, +as it is indeed possible to turn a Haskell-level @Integer@ into an AST for an @Int@. + +-} + +module Math.Algebra.Class where + +-- base +import Prelude + ( Integer, Rational + , Word, Int + ) +import qualified Prelude +import qualified Data.Fixed as Fixed +import Foreign.C.Types +import qualified GHC.Float as Float + +-- half +import qualified Numeric.Half as Half + +-- fir +import Deriving.Base + ( Base(..) ) -- newtype for deriving via base instances +import Math.Logic.Class + ( Eq(Logic,(==)), Ord + , ifThenElse + ) +import FIR.Prelude + +---------------------------------------------------------------------------- + +infixl 6 + +infixl 6 - +infixl 7 * +infixl 7 / +infixr 8 ** + +class AdditiveMonoid a where + -- | Addition. + (+) :: a -> a -> a + -- | Identity for addition. + zero :: a + fromInteger :: Integer -> a + -- technically should be a method of "Ring" + -- but there is no rebindable syntax for "fromNatural" + +instance Prelude.Num a => AdditiveMonoid (Base a) where + (+) = coerce ( (Prelude.+) :: a -> a -> a ) + zero = coerce ( 0 :: a ) + fromInteger = (coerce :: a -> Base a) . Prelude.fromInteger + +deriving via Base Word8 instance AdditiveMonoid Word8 +deriving via Base Word16 instance AdditiveMonoid Word16 +deriving via Base Word32 instance AdditiveMonoid Word32 +deriving via Base Word64 instance AdditiveMonoid Word64 +deriving via Base Word instance AdditiveMonoid Word +deriving via Base Int8 instance AdditiveMonoid Int8 +deriving via Base Int16 instance AdditiveMonoid Int16 +deriving via Base Int32 instance AdditiveMonoid Int32 +deriving via Base Int64 instance AdditiveMonoid Int64 +deriving via Base Int instance AdditiveMonoid Int +deriving via Base Half instance AdditiveMonoid Half +deriving via Base Float instance AdditiveMonoid Float +deriving via Base Double instance AdditiveMonoid Double + +deriving via Base CChar instance AdditiveMonoid CChar +deriving via Base CSChar instance AdditiveMonoid CSChar +deriving via Base CUChar instance AdditiveMonoid CUChar +deriving via Base CShort instance AdditiveMonoid CShort +deriving via Base CUShort instance AdditiveMonoid CUShort +deriving via Base CInt instance AdditiveMonoid CInt +deriving via Base CUInt instance AdditiveMonoid CUInt +deriving via Base CLong instance AdditiveMonoid CLong +deriving via Base CULong instance AdditiveMonoid CULong +deriving via Base CLLong instance AdditiveMonoid CLLong +deriving via Base CULLong instance AdditiveMonoid CULLong +deriving via Base CFloat instance AdditiveMonoid CFloat +deriving via Base CDouble instance AdditiveMonoid CDouble + +deriving via Base (Complex a) instance Prelude.RealFloat a => AdditiveMonoid (Complex a) + +class AdditiveMonoid a => Semiring a where + -- | Multiplication. + (*) :: a -> a -> a + +instance Prelude.Num a => Semiring (Base a) where + (*) = coerce ( (Prelude.*) :: a -> a -> a ) + +deriving via Base Word8 instance Semiring Word8 +deriving via Base Word16 instance Semiring Word16 +deriving via Base Word32 instance Semiring Word32 +deriving via Base Word64 instance Semiring Word64 +deriving via Base Word instance Semiring Word +deriving via Base Int8 instance Semiring Int8 +deriving via Base Int16 instance Semiring Int16 +deriving via Base Int32 instance Semiring Int32 +deriving via Base Int64 instance Semiring Int64 +deriving via Base Int instance Semiring Int +deriving via Base Half instance Semiring Half +deriving via Base Float instance Semiring Float +deriving via Base Double instance Semiring Double + +deriving via Base CChar instance Semiring CChar +deriving via Base CSChar instance Semiring CSChar +deriving via Base CUChar instance Semiring CUChar +deriving via Base CShort instance Semiring CShort +deriving via Base CUShort instance Semiring CUShort +deriving via Base CInt instance Semiring CInt +deriving via Base CUInt instance Semiring CUInt +deriving via Base CLong instance Semiring CLong +deriving via Base CULong instance Semiring CULong +deriving via Base CLLong instance Semiring CLLong +deriving via Base CULLong instance Semiring CULLong +deriving via Base CFloat instance Semiring CFloat +deriving via Base CDouble instance Semiring CDouble + +deriving via Base (Complex a) instance Prelude.RealFloat a => Semiring (Complex a) + +-- | Cancellative monoid under addition. +class AdditiveMonoid a => CancellativeAdditiveMonoid a where + -- | Left-inverse to addition: + -- + -- > ( \ x -> x - y ) . ( \ x -> x + y ) = id + -- + -- Might be partially undefined or underflow, + -- as ( \ x -> x + y ) need not be surjective for any fixed y. + (-) :: a -> a -> a + +instance Prelude.Num a => CancellativeAdditiveMonoid (Base a) where + (-) = coerce ( (Prelude.-) :: a -> a -> a ) + +deriving via Base Word8 instance CancellativeAdditiveMonoid Word8 +deriving via Base Word16 instance CancellativeAdditiveMonoid Word16 +deriving via Base Word32 instance CancellativeAdditiveMonoid Word32 +deriving via Base Word64 instance CancellativeAdditiveMonoid Word64 +deriving via Base Word instance CancellativeAdditiveMonoid Word +deriving via Base Int8 instance CancellativeAdditiveMonoid Int8 +deriving via Base Int16 instance CancellativeAdditiveMonoid Int16 +deriving via Base Int32 instance CancellativeAdditiveMonoid Int32 +deriving via Base Int64 instance CancellativeAdditiveMonoid Int64 +deriving via Base Int instance CancellativeAdditiveMonoid Int +deriving via Base Half instance CancellativeAdditiveMonoid Half +deriving via Base Float instance CancellativeAdditiveMonoid Float +deriving via Base Double instance CancellativeAdditiveMonoid Double + +deriving via Base CChar instance CancellativeAdditiveMonoid CChar +deriving via Base CSChar instance CancellativeAdditiveMonoid CSChar +deriving via Base CUChar instance CancellativeAdditiveMonoid CUChar +deriving via Base CShort instance CancellativeAdditiveMonoid CShort +deriving via Base CUShort instance CancellativeAdditiveMonoid CUShort +deriving via Base CInt instance CancellativeAdditiveMonoid CInt +deriving via Base CUInt instance CancellativeAdditiveMonoid CUInt +deriving via Base CLong instance CancellativeAdditiveMonoid CLong +deriving via Base CULong instance CancellativeAdditiveMonoid CULong +deriving via Base CLLong instance CancellativeAdditiveMonoid CLLong +deriving via Base CULLong instance CancellativeAdditiveMonoid CULLong +deriving via Base CFloat instance CancellativeAdditiveMonoid CFloat +deriving via Base CDouble instance CancellativeAdditiveMonoid CDouble + +deriving via Base (Complex a) instance Prelude.RealFloat a => CancellativeAdditiveMonoid (Complex a) + +-- | Additive group. +class CancellativeAdditiveMonoid a => AdditiveGroup a where + -- | Negation. + negate :: a -> a + +instance Prelude.Num a => AdditiveGroup (Base a) where + negate = coerce ( Prelude.negate :: a -> a ) + +deriving via Base Int8 instance AdditiveGroup Int8 +deriving via Base Int16 instance AdditiveGroup Int16 +deriving via Base Int32 instance AdditiveGroup Int32 +deriving via Base Int64 instance AdditiveGroup Int64 +deriving via Base Int instance AdditiveGroup Int +deriving via Base Half instance AdditiveGroup Half +deriving via Base Float instance AdditiveGroup Float +deriving via Base Double instance AdditiveGroup Double + +deriving via Base CChar instance AdditiveGroup CChar +deriving via Base CSChar instance AdditiveGroup CSChar +deriving via Base CShort instance AdditiveGroup CShort +deriving via Base CInt instance AdditiveGroup CInt +deriving via Base CLong instance AdditiveGroup CLong +deriving via Base CLLong instance AdditiveGroup CLLong +deriving via Base CFloat instance AdditiveGroup CFloat +deriving via Base CDouble instance AdditiveGroup CDouble + +deriving via Base (Complex a) instance Prelude.RealFloat a => AdditiveGroup (Complex a) + +class AdditiveGroup a => Signed a where + -- | Absolute value. + abs :: a -> a + -- | Sign. + -- + -- > signum 5 = 1 + -- > signum -7 = -1 + -- > signum 0 = 0 + signum :: a -> a + +instance Prelude.Num a => Signed (Base a) where + abs = coerce ( Prelude.abs :: a -> a ) + signum = coerce ( Prelude.signum :: a -> a ) + +deriving via Base Int8 instance Signed Int8 +deriving via Base Int16 instance Signed Int16 +deriving via Base Int32 instance Signed Int32 +deriving via Base Int64 instance Signed Int64 +deriving via Base Int instance Signed Int +deriving via Base Half instance Signed Half +deriving via Base Float instance Signed Float +deriving via Base Double instance Signed Double + +deriving via Base CChar instance Signed CChar +deriving via Base CSChar instance Signed CSChar +deriving via Base CShort instance Signed CShort +deriving via Base CInt instance Signed CInt +deriving via Base CLong instance Signed CLong +deriving via Base CLLong instance Signed CLLong +deriving via Base CFloat instance Signed CFloat +deriving via Base CDouble instance Signed CDouble + +class (Semiring a, AdditiveGroup a) => Ring a where +instance (Semiring a, AdditiveGroup a) => Ring a where + +class Ring a => DivisionRing a where + {-# MINIMAL ( (/) | recip ), fromRational #-} + -- | Division. + (/) :: a -> a -> a + -- | Reciprocal. + recip :: a -> a + fromRational :: Rational -> a + + recip a = fromInteger 1 / a + a / b = a * recip b + +instance Prelude.Fractional a => DivisionRing (Base a) where + (/) = coerce ( (Prelude./) :: a -> a -> a ) + recip = coerce ( Prelude.recip :: a -> a ) + fromRational = ( coerce :: a -> Base a ) . Prelude.fromRational + +deriving via Base Half instance DivisionRing Half +deriving via Base Float instance DivisionRing Float +deriving via Base Double instance DivisionRing Double + +deriving via Base CFloat instance DivisionRing CFloat +deriving via Base CDouble instance DivisionRing CDouble + +deriving via Base (Complex a) instance Prelude.RealFloat a => DivisionRing (Complex a) + +-- totally ordered archimedean monoids +class (Ord a, AdditiveMonoid a) => Archimedean a where + mod :: a -> a -> a + rem :: a -> a -> a + div :: a -> a -> a + divMod :: a -> a -> (a,a) + divMod a b = ( div a b, mod a b ) + +instance ( Ord a, CancellativeAdditiveMonoid a, Prelude.Integral a ) => Archimedean (Base a) where + mod = coerce ( Prelude.mod :: a -> a -> a ) + rem = coerce ( Prelude.rem :: a -> a -> a ) + div = coerce ( Prelude.div :: a -> a -> a ) + divMod = coerce ( Prelude.divMod :: a -> a -> (a,a) ) + +deriving via Base Word8 instance Archimedean Word8 +deriving via Base Word16 instance Archimedean Word16 +deriving via Base Word32 instance Archimedean Word32 +deriving via Base Word64 instance Archimedean Word64 +deriving via Base Word instance Archimedean Word +deriving via Base Int8 instance Archimedean Int8 +deriving via Base Int16 instance Archimedean Int16 +deriving via Base Int32 instance Archimedean Int32 +deriving via Base Int64 instance Archimedean Int64 +deriving via Base Int instance Archimedean Int + +deriving via Base CChar instance Archimedean CChar +deriving via Base CSChar instance Archimedean CSChar +deriving via Base CUChar instance Archimedean CUChar +deriving via Base CShort instance Archimedean CShort +deriving via Base CUShort instance Archimedean CUShort +deriving via Base CInt instance Archimedean CInt +deriving via Base CUInt instance Archimedean CUInt +deriving via Base CLong instance Archimedean CLong +deriving via Base CULong instance Archimedean CULong +deriving via Base CLLong instance Archimedean CLLong +deriving via Base CULLong instance Archimedean CULLong + +newtype Fixed a = Fixed { runFixed :: a } +deriving via a instance Eq a + => Eq (Fixed a) +deriving via a instance Ord a + => Ord (Fixed a) +deriving via a instance AdditiveMonoid a + => AdditiveMonoid (Fixed a) +deriving via a instance CancellativeAdditiveMonoid a + => CancellativeAdditiveMonoid (Fixed a) +deriving via a instance AdditiveGroup a + => AdditiveGroup (Fixed a) +deriving via a instance Semiring a + => Semiring (Fixed a) +deriving via a instance Signed a + => Signed (Fixed a) + +instance ( Eq a, Logic a ~ Bool + , Ord a + , Ring a, Signed a + , Prelude.Real a + ) => Archimedean (Fixed a) where + mod = coerce ( Fixed.mod' :: a -> a -> a ) + rem a m = ifThenElse (signum a == signum m) + ( mod a m ) + ( negate ( mod a m ) ) + div (Fixed a) (Fixed b) + = Fixed $ fromInteger ( Fixed.div' a b ) + divMod (Fixed a) (Fixed b) + = case Fixed.divMod' a b of + (q,r) -> ( Fixed (fromInteger q), Fixed r ) + +deriving via Fixed Half instance Archimedean Half +deriving via Fixed Float instance Archimedean Float +deriving via Fixed Double instance Archimedean Double + +deriving via Fixed CFloat instance Archimedean CFloat +deriving via Fixed CDouble instance Archimedean CDouble + + +class DivisionRing a => Floating a where + pi :: a + exp, log :: a -> a + sqrt, invSqrt :: a -> a + sin, cos, tan :: a -> a + asin, acos, atan :: a -> a + sinh, cosh, tanh :: a -> a + asinh, acosh, atanh :: a -> a + (**) :: a -> a -> a + -- no logBase + +instance Prelude.Floating a => Floating (Base a) where + pi = coerce ( Prelude.pi :: a) + exp = coerce ( Prelude.exp :: a -> a ) + log = coerce ( Prelude.log :: a -> a ) + sqrt = coerce ( Prelude.sqrt :: a -> a ) + sin = coerce ( Prelude.sin :: a -> a ) + cos = coerce ( Prelude.cos :: a -> a ) + tan = coerce ( Prelude.tan :: a -> a ) + asin = coerce ( Prelude.asin :: a -> a ) + acos = coerce ( Prelude.acos :: a -> a ) + atan = coerce ( Prelude.atan :: a -> a ) + sinh = coerce ( Prelude.sinh :: a -> a ) + cosh = coerce ( Prelude.cosh :: a -> a ) + tanh = coerce ( Prelude.tanh :: a -> a ) + asinh = coerce ( Prelude.asinh :: a -> a ) + acosh = coerce ( Prelude.acosh :: a -> a ) + atanh = coerce ( Prelude.atanh :: a -> a ) + (**) = coerce ( (Prelude.**) :: a -> a -> a ) + invSqrt = recip . sqrt + +deriving via Base Half instance Floating Half +deriving via Base Float instance Floating Float +deriving via Base Double instance Floating Double + +deriving via Base CFloat instance Floating CFloat +deriving via Base CDouble instance Floating CDouble + +deriving via Base (Complex a) instance Prelude.RealFloat a => Floating (Complex a) + +class ( Floating a, Eq a ) => RealFloat a where + atan2 :: a -> a -> a + isNaN :: a -> Logic a + isInfinite :: a -> Logic a + +instance ( Prelude.RealFloat a, Prelude.Eq a ) => RealFloat (Base a) where + atan2 = coerce ( Prelude.atan2 :: a -> a -> a ) + isNaN = coerce ( Prelude.isNaN :: a -> Bool ) + isInfinite = coerce ( Prelude.isInfinite :: a -> Bool ) + +deriving via Base Half instance RealFloat Half +deriving via Base Float instance RealFloat Float +deriving via Base Double instance RealFloat Double + +deriving via Base CFloat instance RealFloat CFloat +deriving via Base CDouble instance RealFloat CDouble + + +class ComplexFloat c a | c -> a where + conjugate :: c -> c + magnitude :: c -> a + -- | Squared magnitude, without the square root. + squaredMagnitude :: c -> a + phase :: c -> a + mkCartesian :: a -> a -> c + mkPolar :: a -> a -> c + cis :: a -> c + scale :: a -> c -> c + realPart :: c -> a + imagPart :: c -> a + +instance (RealFloat a, b ~ a) => ComplexFloat (Complex a) b where + conjugate ( a :+ b ) = a :+ negate b + magnitude ( a :+ b ) = sqrt ( a * a + b * b ) + squaredMagnitude ( a :+ b ) = a * a + b * b + phase ( a :+ b ) = atan2 b a + mkCartesian = (:+) + mkPolar r theta = scale r $ cis theta + cis theta = cos theta :+ sin theta + scale r = Prelude.fmap ( r * ) + realPart ( a :+ _ ) = a + imagPart ( _ :+ b ) = b + +-- constraint for integer types, +-- no methods +class Semiring a => Integral a where +instance Integral Word8 where +instance Integral Word16 where +instance Integral Word32 where +instance Integral Word64 where +instance Integral Word where +instance Integral Int8 where +instance Integral Int16 where +instance Integral Int32 where +instance Integral Int64 where +instance Integral Int where +instance Integral CChar where +instance Integral CSChar where +instance Integral CUChar where +instance Integral CShort where +instance Integral CUShort where +instance Integral CInt where +instance Integral CUInt where +instance Integral CLong where +instance Integral CULong where +instance Integral CLLong where +instance Integral CULLong where + +-- constraint for unsigned integer types, +-- no methods +class Integral a => Unsigned a where +instance Unsigned Word8 where +instance Unsigned Word16 where +instance Unsigned Word32 where +instance Unsigned Word64 where +instance Unsigned Word where +instance Unsigned CUChar where +instance Unsigned CUShort where +instance Unsigned CUInt where +instance Unsigned CULong where +instance Unsigned CULLong where + + +type family Arr (domCod :: (Type,Type)) = (arr :: Type) | arr -> domCod where + Arr '(dom, cod) = dom -> cod + +class Convert (c :: (Type,Type)) where + convert :: Arr c + +instance Convert '(a,a) where + convert = id + +-- fromIntegral conversions +instance (Prelude.Integral a, Prelude.Num b) => Convert '(Base a, b) where + convert (Base a) = Prelude.fromIntegral a + +-- to unsigned integers +deriving via '(Base Word16, Word8 ) instance Convert '(Word16, Word8 ) +deriving via '(Base Word32, Word8 ) instance Convert '(Word32, Word8 ) +deriving via '(Base Word64, Word8 ) instance Convert '(Word64, Word8 ) +deriving via '(Base Word , Word8 ) instance Convert '(Word , Word8 ) +deriving via '(Base Int8 , Word8 ) instance Convert '(Int8 , Word8 ) +deriving via '(Base Int16 , Word8 ) instance Convert '(Int16 , Word8 ) +deriving via '(Base Int32 , Word8 ) instance Convert '(Int32 , Word8 ) +deriving via '(Base Int64 , Word8 ) instance Convert '(Int64 , Word8 ) +deriving via '(Base Int , Word8 ) instance Convert '(Int , Word8 ) +deriving via '(Base Word8 , Word16) instance Convert '(Word8 , Word16) +deriving via '(Base Word32, Word16) instance Convert '(Word32, Word16) +deriving via '(Base Word64, Word16) instance Convert '(Word64, Word16) +deriving via '(Base Word , Word16) instance Convert '(Word , Word16) +deriving via '(Base Int8 , Word16) instance Convert '(Int8 , Word16) +deriving via '(Base Int16 , Word16) instance Convert '(Int16 , Word16) +deriving via '(Base Int32 , Word16) instance Convert '(Int32 , Word16) +deriving via '(Base Int64 , Word16) instance Convert '(Int64 , Word16) +deriving via '(Base Int , Word16) instance Convert '(Int , Word16) +deriving via '(Base Word8 , Word32) instance Convert '(Word8 , Word32) +deriving via '(Base Word16, Word32) instance Convert '(Word16, Word32) +deriving via '(Base Word64, Word32) instance Convert '(Word64, Word32) +deriving via '(Base Word , Word32) instance Convert '(Word , Word32) +deriving via '(Base Int8 , Word32) instance Convert '(Int8 , Word32) +deriving via '(Base Int16 , Word32) instance Convert '(Int16 , Word32) +deriving via '(Base Int32 , Word32) instance Convert '(Int32 , Word32) +deriving via '(Base Int64 , Word32) instance Convert '(Int64 , Word32) +deriving via '(Base Int , Word32) instance Convert '(Int , Word32) +deriving via '(Base Word8 , Word64) instance Convert '(Word8 , Word64) +deriving via '(Base Word16, Word64) instance Convert '(Word16, Word64) +deriving via '(Base Word32, Word64) instance Convert '(Word32, Word64) +deriving via '(Base Word , Word64) instance Convert '(Word , Word64) +deriving via '(Base Int8 , Word64) instance Convert '(Int8 , Word64) +deriving via '(Base Int16 , Word64) instance Convert '(Int16 , Word64) +deriving via '(Base Int32 , Word64) instance Convert '(Int32 , Word64) +deriving via '(Base Int64 , Word64) instance Convert '(Int64 , Word64) +deriving via '(Base Int , Word64) instance Convert '(Int , Word64) +deriving via '(Base Word8 , Word ) instance Convert '(Word8 , Word ) +deriving via '(Base Word16, Word ) instance Convert '(Word16, Word ) +deriving via '(Base Word32, Word ) instance Convert '(Word32, Word ) +deriving via '(Base Word64, Word ) instance Convert '(Word64, Word ) +deriving via '(Base Int8 , Word ) instance Convert '(Int8 , Word ) +deriving via '(Base Int16 , Word ) instance Convert '(Int16 , Word ) +deriving via '(Base Int32 , Word ) instance Convert '(Int32 , Word ) +deriving via '(Base Int64 , Word ) instance Convert '(Int64 , Word ) +deriving via '(Base Int , Word ) instance Convert '(Int , Word ) +-- to signed integers +deriving via '(Base Word8 , Int8 ) instance Convert '(Word8 , Int8 ) +deriving via '(Base Word16, Int8 ) instance Convert '(Word16, Int8 ) +deriving via '(Base Word32, Int8 ) instance Convert '(Word32, Int8 ) +deriving via '(Base Word64, Int8 ) instance Convert '(Word64, Int8 ) +deriving via '(Base Word , Int8 ) instance Convert '(Word , Int8 ) +deriving via '(Base Int16 , Int8 ) instance Convert '(Int16 , Int8 ) +deriving via '(Base Int32 , Int8 ) instance Convert '(Int32 , Int8 ) +deriving via '(Base Int64 , Int8 ) instance Convert '(Int64 , Int8 ) +deriving via '(Base Int , Int8 ) instance Convert '(Int , Int8 ) +deriving via '(Base Word8 , Int16 ) instance Convert '(Word8 , Int16 ) +deriving via '(Base Word16, Int16 ) instance Convert '(Word16, Int16 ) +deriving via '(Base Word32, Int16 ) instance Convert '(Word32, Int16 ) +deriving via '(Base Word64, Int16 ) instance Convert '(Word64, Int16 ) +deriving via '(Base Word , Int16 ) instance Convert '(Word , Int16 ) +deriving via '(Base Int8 , Int16 ) instance Convert '(Int8 , Int16 ) +deriving via '(Base Int32 , Int16 ) instance Convert '(Int32 , Int16 ) +deriving via '(Base Int64 , Int16 ) instance Convert '(Int64 , Int16 ) +deriving via '(Base Int , Int16 ) instance Convert '(Int , Int16 ) +deriving via '(Base Word8 , Int32 ) instance Convert '(Word8 , Int32 ) +deriving via '(Base Word16, Int32 ) instance Convert '(Word16, Int32 ) +deriving via '(Base Word32, Int32 ) instance Convert '(Word32, Int32 ) +deriving via '(Base Word64, Int32 ) instance Convert '(Word64, Int32 ) +deriving via '(Base Word , Int32 ) instance Convert '(Word , Int32 ) +deriving via '(Base Int8 , Int32 ) instance Convert '(Int8 , Int32 ) +deriving via '(Base Int16 , Int32 ) instance Convert '(Int16 , Int32 ) +deriving via '(Base Int64 , Int32 ) instance Convert '(Int64 , Int32 ) +deriving via '(Base Int , Int32 ) instance Convert '(Int , Int32 ) +deriving via '(Base Word8 , Int64 ) instance Convert '(Word8 , Int64 ) +deriving via '(Base Word16, Int64 ) instance Convert '(Word16, Int64 ) +deriving via '(Base Word32, Int64 ) instance Convert '(Word32, Int64 ) +deriving via '(Base Word64, Int64 ) instance Convert '(Word64, Int64 ) +deriving via '(Base Word , Int64 ) instance Convert '(Word , Int64 ) +deriving via '(Base Int8 , Int64 ) instance Convert '(Int8 , Int64 ) +deriving via '(Base Int16 , Int64 ) instance Convert '(Int16 , Int64 ) +deriving via '(Base Int32 , Int64 ) instance Convert '(Int32 , Int64 ) +deriving via '(Base Int , Int64 ) instance Convert '(Int , Int64 ) +deriving via '(Base Word8 , Int ) instance Convert '(Word8 , Int ) +deriving via '(Base Word16, Int ) instance Convert '(Word16, Int ) +deriving via '(Base Word32, Int ) instance Convert '(Word32, Int ) +deriving via '(Base Word64, Int ) instance Convert '(Word64, Int ) +deriving via '(Base Word , Int ) instance Convert '(Word , Int ) +deriving via '(Base Int8 , Int ) instance Convert '(Int8 , Int ) +deriving via '(Base Int16 , Int ) instance Convert '(Int16 , Int ) +deriving via '(Base Int32 , Int ) instance Convert '(Int32 , Int ) +deriving via '(Base Int64 , Int ) instance Convert '(Int64 , Int ) +-- to floating point +deriving via '(Base Word8 , Half ) instance Convert '(Word8 , Half ) +deriving via '(Base Word16, Half ) instance Convert '(Word16, Half ) +deriving via '(Base Word32, Half ) instance Convert '(Word32, Half ) +deriving via '(Base Word64, Half ) instance Convert '(Word64, Half ) +deriving via '(Base Word , Half ) instance Convert '(Word , Half ) +deriving via '(Base Int8 , Half ) instance Convert '(Int8 , Half ) +deriving via '(Base Int16 , Half ) instance Convert '(Int16 , Half ) +deriving via '(Base Int32 , Half ) instance Convert '(Int32 , Half ) +deriving via '(Base Int64 , Half ) instance Convert '(Int64 , Half ) +deriving via '(Base Word8 , Float ) instance Convert '(Word8 , Float ) +deriving via '(Base Word16, Float ) instance Convert '(Word16, Float ) +deriving via '(Base Word32, Float ) instance Convert '(Word32, Float ) +deriving via '(Base Word64, Float ) instance Convert '(Word64, Float ) +deriving via '(Base Word , Float ) instance Convert '(Word , Float ) +deriving via '(Base Int8 , Float ) instance Convert '(Int8 , Float ) +deriving via '(Base Int16 , Float ) instance Convert '(Int16 , Float ) +deriving via '(Base Int32 , Float ) instance Convert '(Int32 , Float ) +deriving via '(Base Int64 , Float ) instance Convert '(Int64 , Float ) +deriving via '(Base Word8 , Double) instance Convert '(Word8 , Double) +deriving via '(Base Word16, Double) instance Convert '(Word16, Double) +deriving via '(Base Word32, Double) instance Convert '(Word32, Double) +deriving via '(Base Word64, Double) instance Convert '(Word64, Double) +deriving via '(Base Word , Double) instance Convert '(Word , Double) +deriving via '(Base Int8 , Double) instance Convert '(Int8 , Double) +deriving via '(Base Int16 , Double) instance Convert '(Int16 , Double) +deriving via '(Base Int32 , Double) instance Convert '(Int32 , Double) +deriving via '(Base Int64 , Double) instance Convert '(Int64 , Double) + +-- floating conversions +instance Convert '(Half , Float ) where + convert = Half.fromHalf +instance Convert '(Half , Double) where + convert = Float.float2Double . Half.fromHalf +instance Convert '(Float , Double) where + convert = Float.float2Double +instance Convert '(Float , Half ) where + convert = Half.toHalf +instance Convert '(Double, Half ) where + convert = Half.toHalf . Float.double2Float +instance Convert '(Double, Float ) where + convert = Float.double2Float + +fromIntegral :: (Convert '(a,b), Integral a) => a -> b +fromIntegral = convert + +realToFrac :: (Convert '(a,b), Floating a, DivisionRing b) => a -> b +realToFrac = convert + +-- truncation/rounding/etc +class Rounding (c :: (Type,Type)) where + -- | Truncate (towards 0). + truncate :: Arr c + round :: Arr c + floor :: Arr c + ceiling :: Arr c + +instance (Prelude.RealFrac a, Prelude.Integral b) => Rounding '(a, Base b) where + truncate = Base . Prelude.truncate + round = Base . Prelude.round + floor = Base . Prelude.floor + ceiling = Base . Prelude.ceiling + +instance (Prelude.RealFrac a, Prelude.Num b) => Rounding '(Base a, b) where + truncate = Prelude.fromIntegral . Prelude.truncate @_ @Int64 . runBase + round = Prelude.fromIntegral . Prelude.round @_ @Int64 . runBase + floor = Prelude.fromIntegral . Prelude.floor @_ @Int64 . runBase + ceiling = Prelude.fromIntegral . Prelude.ceiling @_ @Int64 . runBase + +-- to unsigned integers +deriving via '(Half , Base Word8 ) instance Rounding '(Half , Word8 ) +deriving via '(Half , Base Word16) instance Rounding '(Half , Word16) +deriving via '(Half , Base Word32) instance Rounding '(Half , Word32) +deriving via '(Half , Base Word64) instance Rounding '(Half , Word64) +deriving via '(Half , Base Word ) instance Rounding '(Half , Word ) +deriving via '(Float , Base Word8 ) instance Rounding '(Float , Word8 ) +deriving via '(Float , Base Word16) instance Rounding '(Float , Word16) +deriving via '(Float , Base Word32) instance Rounding '(Float , Word32) +deriving via '(Float , Base Word64) instance Rounding '(Float , Word64) +deriving via '(Float , Base Word ) instance Rounding '(Float , Word ) +deriving via '(Double, Base Word8 ) instance Rounding '(Double, Word8 ) +deriving via '(Double, Base Word16) instance Rounding '(Double, Word16) +deriving via '(Double, Base Word32) instance Rounding '(Double, Word32) +deriving via '(Double, Base Word64) instance Rounding '(Double, Word64) +deriving via '(Double, Base Word ) instance Rounding '(Double, Word ) +-- to signed integers +deriving via '(Half , Base Int8 ) instance Rounding '(Half , Int8 ) +deriving via '(Half , Base Int16 ) instance Rounding '(Half , Int16 ) +deriving via '(Half , Base Int32 ) instance Rounding '(Half , Int32 ) +deriving via '(Half , Base Int64 ) instance Rounding '(Half , Int64 ) +deriving via '(Half , Base Int ) instance Rounding '(Half , Int ) +deriving via '(Float , Base Int8 ) instance Rounding '(Float , Int8 ) +deriving via '(Float , Base Int16 ) instance Rounding '(Float , Int16 ) +deriving via '(Float , Base Int32 ) instance Rounding '(Float , Int32 ) +deriving via '(Float , Base Int64 ) instance Rounding '(Float , Int64 ) +deriving via '(Float , Base Int ) instance Rounding '(Float , Int ) +deriving via '(Double, Base Int8 ) instance Rounding '(Double, Int8 ) +deriving via '(Double, Base Int16 ) instance Rounding '(Double, Int16 ) +deriving via '(Double, Base Int32 ) instance Rounding '(Double, Int32 ) +deriving via '(Double, Base Int64 ) instance Rounding '(Double, Int64 ) +deriving via '(Double, Base Int ) instance Rounding '(Double, Int ) +-- to floating point +deriving via '(Base Half , Half ) instance Rounding '(Half , Half ) +deriving via '(Base Half , Float ) instance Rounding '(Half , Float ) +deriving via '(Base Half , Double) instance Rounding '(Half , Double) +deriving via '(Base Float , Half ) instance Rounding '(Float , Half ) +deriving via '(Base Float , Float ) instance Rounding '(Float , Float ) +deriving via '(Base Float , Double) instance Rounding '(Float , Double) +deriving via '(Base Double, Half ) instance Rounding '(Double, Half ) +deriving via '(Base Double, Float ) instance Rounding '(Double, Float ) +deriving via '(Base Double, Double) instance Rounding '(Double, Double) diff --git a/src/Math/Algebra/GradedSemigroup.hs b/src/Math/Algebra/GradedSemigroup.hs new file mode 100644 --- /dev/null +++ b/src/Math/Algebra/GradedSemigroup.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: Math.Algebra.GradedSemigroup + +A /graded/ object is one which splits up into parts of different indices. + +For instance, the ring of polynomials \( R[x_1, \ldots, x_n] \) is graded +by degree, in that \( R \) can be decomposed: + +\[ R = \bigoplus_{d \in \mathbb{N}} R_d, \] + +where \( R_d \) consists of homogeneous polynomials of degree \( d \). + +What's important is how the ring structure of \( R[x_1, \ldots, x_n] \) interacts with the grading. +We have: + +\[ (+) \ \colon R_{d\phantom{_1}} \times R_{d\phantom{_2}} \to R_{d\phantom{_1+d_2}} \] + +\[ (\times) \ \colon R_{d_1} \times R_{d_2} \to R_{d_1 + d_2}. \] + +In this module, we are interested in the /second/ of these two behaviours. +Note then that two operations are in play: + + * the monoid \( \mathbb{N} \) of degrees under addition, + * the graded multiplication \[ (\times) \ \colon R_{d_1} \times R_{d_2} \to R_{d_1 + d_2}. \] + +One can alternatively think of a graded semigroup as a semigroup in a (monoidal) category of graded objects. + +A motivating example is that of length-indexed vectors. In that case, we have: + + * type-level addition of natural numbers \( (+) \ \colon \mathbb{N} \times \mathbb{N} \to \mathbb{N}, \) + * value-level concatenation of vectors \( \textrm{V}\ n\ a \times \textrm{V}\ m\ a \to \textrm{V}\ (n+m)\ a. \) + +Another important example is that of structs (i.e. ordered records). In this case we have: + + * a type-level monoid operation on lists of fields, + @(:++:) :: [ Symbol :-> Type ] -> [ Symbol :-> Type ] -> [ Symbol :-> Type ]@, + * a value-level concatenation of structs, of type @Struct as -> Struct bs -> Struct (as :++: bs)@. + +In this module, we follow the above two examples and insist that the operation on indices is at the type-level, +whereas the graded multiplication sits at the value-level. +-} + +module Math.Algebra.GradedSemigroup where + +-- base +import Data.Kind + ( Type ) + + +infixl 6 +infixl 6 :: + +-- * Graded semigroups + +-- $graded +-- A __graded semigroup__ consists of: +-- +-- * Types \( G_i \) for \( i : I \), where \( I \) is the index type (also called the degree type), +-- * a semigroup structure \( (+) \ \colon I \times I \to I \) on the index type \( I \), +-- * an associative operation \( (\cdot) \ \colon G_i \times G_j \to G_{i + j} \). + +-- | Semigroup with graded structure. +class GradedSemigroup g k | g -> k where + -- | For extra flexibility, instead of specifying a type-level function \( G \colon I \to \textrm{Type} \) + -- to define the grading (which is often too restrictive), we use an associated /injective/ type family. + type Grade k g (i :: k) = (r :: Type) | r -> k g i + -- | Type-level semigroup operation on indices. + type (i :: k) :: (j :: k) :: k + -- | Value-level graded semigroup operation. + () :: Grade k g i -> Grade k g j -> Grade k g (i :: j) diff --git a/src/Math/Linear.hs b/src/Math/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Math/Linear.hs @@ -0,0 +1,835 @@ +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Math.Linear +Description: @---@ Vectors & matrices, as used by this library. __Import required to use vectors & matrices.__ + +Vectors and matrices, indexed by dimension. + +Vectors are represented as linked lists, whereas matrices are represented as a vector of their columns, +following the conventions from Vulkan/OpenGL. +-} + +module Math.Linear + ( + -- * Vector and matrix types + V(..), M(..) + + -- * Typeclasses + -- ** Vectors + , Semimodule(..), LinearModule(..), Inner(..), Cross(..) + -- ** Matrices + , VectorOf, Matrix(..) + + -- * General vector operations + , angle, norm, squaredNorm + , quadrance, distance + , along + , reflect, reflect' + , proj, projC + , isOrthogonal, gramSchmidt + , rotateAroundAxis + + -- * Operations involving the vector data type + , headV, tailV, headTailV + , (^!), at, replaceV + , sum + , buildV + , dfoldrV + , unfold + , pattern V0, pattern V1, pattern V2, pattern V3, pattern V4 + + -- * Operations involving vectors of vectors + , blockSum + + -- * Operations involving the matrix newtype + , perspective, lookAt + ) +where + +-- base +import Prelude hiding + ( Eq(..), (&&), (||) + , Ord(..) + , Num(..), sum + , Fractional(..), Floating(..) + , Ordering(..) + ) +import qualified Prelude +import Control.Arrow + ( second ) +import Data.Foldable + ( traverse_ ) +import Data.Functor.Compose + ( Compose(..) ) +import Data.Kind + ( Type, Constraint ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import Data.Proxy + ( Proxy(Proxy) ) +import Foreign.Ptr + ( Ptr, castPtr ) +import Foreign.Storable + ( Storable(alignment, sizeOf, peek, poke, peekElemOff, pokeElemOff) ) +import GHC.Base + ( Int#, Int(I#), (+#) ) +import GHC.TypeNats + ( Nat, KnownNat, natVal + , type (+), type (-), type (*) + , CmpNat, type (<=), type (<=?) + , sameNat + ) +import Numeric.Natural + ( Natural ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- binary +import Data.Binary + ( Binary(put,get) ) + +-- distributive +import Data.Distributive + ( Distributive(..) ) + +-- typelits-witnesses +import GHC.TypeLits.Compare + ( (:<=?)(LE,NLE), (%<=?) ) + +-- fir +import Control.Arrow.Strength + ( strong ) +import {-# SOURCE #-} Data.Product + ( IsProduct(..) + , HList(HNil, (:>)) + ) +import Data.Type.List + ( Replicate + , Length, KnownLength + ) +import Math.Algebra.Class + ( AdditiveMonoid(..), CancellativeAdditiveMonoid(..), AdditiveGroup(..) + , Semiring(..), Ring + , DivisionRing(..), Floating(..) + ) +import Math.Algebra.GradedSemigroup + ( GradedSemigroup(..) ) +import Math.Logic.Class + ( Boolean(..), Eq(Logic,(==)) + , (#.) + , Ord(..) + ) + +------------------------------------------------------------------------------- + +infixr 3 :. + +-- | Vector data type. +-- +-- @V m a@ denotes a vector of @m@ inhabitants of @a@. +-- Represented as a linked list. +data V :: Nat -> Type -> Type where + VNil :: V 0 a + (:.) :: (1 <= m, m ~ (1+n), n ~ (m-1)) + => a -> V n a -> V m a + +deriving stock instance Functor (V n) +deriving stock instance Foldable (V n) +deriving stock instance Traversable (V n) + +instance (KnownNat n, Show a) => Show (V n a) where + show :: V n a -> String + show v = "V" ++ n ++ foldMap ( \a -> " " ++ show a ) v + where n :: String + n = show (natVal (Proxy @n)) + +deriving stock instance Prelude.Eq a => Prelude.Eq (V n a) +deriving stock instance Prelude.Ord a => Prelude.Ord (V n a) + +instance (KnownNat n, Binary a) => Binary (V n a) where + put = traverse_ put + get = case Proxy @1 %<=? Proxy @n of + LE Refl -> liftA2 (:.) + get + $ get @(V (n-1) a) + NLE nle _ -> + case lt1_is_Zero @n nle of + Refl -> pure VNil + +instance KnownNat n => Distributive (V n) where + distribute :: Functor f => f (V n a) -> V n (f a) + distribute + = case Proxy @1 %<=? Proxy @n of + LE Refl -> uncurry (:.) + . second distribute + . strong + . fmap headTailV + NLE nle _ -> + case lt1_is_Zero @n nle of + Refl -> const VNil + +instance KnownNat n => Applicative (V n) where + pure = unfold id + _ <*> VNil = VNil + (f :. fs) <*> (a :. as) = f a :. fs <*> as +#if !MIN_VERSION_base(4,16,0) + _ <*> _ = error "unreachable" +#endif + +instance (KnownNat n, Eq a) => Eq (V n a) where + type Logic (V n a) = Logic a + (==) = (foldr (&&) true .) . liftA2 (==) + +instance (KnownNat n, Ord a) => Ord (V n a) where + VNil <= VNil = true + (a :. as) <= (b :. bs) = a < b || (a <= b && as <= bs) +#if !MIN_VERSION_base(4,16,0) + _ <= _ = error "unreachable" +#endif + + VNil < VNil = false + (a :. as) < (b :. bs) = a < b || (a <= b && as < bs) +#if !MIN_VERSION_base(4,16,0) + _ < _ = error "unreachable" +#endif + + min = liftA2 min + max = liftA2 max + +instance (KnownNat n, Semigroup a) => Semigroup (V n a) where + (<>) = liftA2 (<>) + +instance (KnownNat n, Monoid a) => Monoid (V n a) where + mempty = pure mempty + +headV :: (KnownNat n, 1 <= n) => V n a -> a +headV (a :. _) = a + +tailV :: (KnownNat n, 1 <= n) => V n a -> V (n-1) a +tailV (_ :. as) = as + +headTailV :: (KnownNat n, 1 <= n) => V n a -> (a, V (n-1) a) +headTailV (a :. as) = ( a, as ) + +splitAtV + :: forall (s :: Nat) (n :: Nat) (a :: Type) + . ( KnownNat s, KnownNat n, s <= n ) + => V n a + -> ( V s a, V (n-s) a ) +splitAtV v = case Proxy @1 %<=? Proxy @s of + LE Refl -> case lte_transitive @1 @s @n of + Refl -> case headTailV v of + ( h, t ) -> case splitAtV @(s-1) t of + ( hs, d ) -> ( h :. hs, d ) + NLE nle _ -> case lt1_is_Zero @s nle of + Refl -> ( VNil, v ) + +instance (KnownNat n, Storable a) => Storable (V n a) where + sizeOf :: V n a -> Int + sizeOf _ = n * sizeOf (undefined :: a) + where n = fromIntegral $ natVal (Proxy @n) + + alignment _ = alignment (undefined :: a) + + poke ptr u = go u 0# + where go :: KnownNat m => V m a -> Int# -> IO() + go VNil _ = pure () + go (a :. v) n# = do + pokeElemOff (castPtr ptr) (I# n#) a + go v (n# +# 1#) + + peek :: Ptr (V n a) -> IO (V n a) + peek ptr = traverse (peekElemOff (castPtr ptr)) ixVec + where ixVec :: V n Int + ixVec = unfold pred (fromIntegral $ natVal (Proxy @n)) + +infixl 9 ^! + +-- | Unsafe indexing. +(^!) :: V n a -> Int -> a +(^!) (a :. _) 0 = a +(^!) VNil _ = error "empty vector" +(^!) (_ :. as) n = as ^! (n-1) + +-- | Safe indexing. +-- +-- Use with /TypeApplications/, +-- e.g. to access index @3@ of vector @v@: @at \@3 v@. +at :: forall i n a. (KnownNat i, KnownNat n, CmpNat i n ~ Prelude.LT) + => V n a -> a +at v = v ^! fromIntegral (dim @i) + +replaceV :: Int -> a -> V n a -> V n a +replaceV _ _ VNil = VNil +replaceV 0 b (_ :. as) = (b :. as) +replaceV i b (a :. as) = a :. replaceV (i-1) b as + +----------------------------------------------------------- +-- todo: temporary workaround + +newtype Sum a = Sum { getSum :: a } +instance AdditiveMonoid a => Semigroup (Sum a) where + (Sum a) <> (Sum b) = Sum (a + b) +instance AdditiveMonoid a => Monoid (Sum a) where + mempty = Sum zero + +sum :: (AdditiveMonoid a, Foldable t) => t a -> a +sum = getSum #. foldMap Sum + +----------------------------------------------------------- +-- some basic facts about inequalities, bypassing the type-checker +-- a proper solution would be to use a type-checking plugin for this + +lt1_is_Zero :: KnownNat n => (1 <=? n) :~: 'False -> (n :~: 0) +lt1_is_Zero _ = unsafeCoerce Refl + +lemma1 :: forall j n. ( KnownNat j, KnownNat n, j <= n, 1 <= (n-j) ) + => ( CmpNat j n :~: Prelude.LT ) +lemma1 = unsafeCoerce Refl + +lemma2 :: forall j n. ( KnownNat j, KnownNat n, j <= n, 1 <= (n-j) ) + => ( (j+1) <=? n ) :~: 'True +lemma2 = unsafeCoerce Refl + +lte_transitive + :: forall i j k + . ( KnownNat i, KnownNat j, KnownNat k, i <= j, j <= k ) + => ( i <=? k ) :~: 'True +lte_transitive = unsafeCoerce Refl + +----------------------------------------------------------- + +-- | Build a vector using a generating function. +buildV :: forall n a. KnownNat n + => ( forall i. (KnownNat i, CmpNat i n ~ Prelude.LT) => Proxy i -> a) + -> V n a +buildV f = go @0 + where + go :: forall j. (KnownNat j, j <= n) => V (n-j) a + go = case Proxy @1 %<=? Proxy @(n-j) of + NLE nle _ -> + case lt1_is_Zero @(n-j) nle of + Refl -> VNil + LE Refl -> case ( lemma1 @j @n, lemma2 @j @n ) of + (Refl, Refl) -> f ( Proxy @j ) :. go @(j+1) + +-- | Dependent fold of a vector. +-- Folds a vector with a function whose type depends on the index. +dfoldrV :: forall n a b. KnownNat n + => (forall k. (KnownNat k, k+1 <= n) => a -> b k -> b (k+1)) -- ^ Function used to fold. + -> b 0 -- ^ Starting value. + -> V n a -- ^ Vector to fold. + -> b n +dfoldrV f d = go + where go :: (KnownNat m, m <= n) => V m a -> b m + go VNil = d + go (a:.as) = f a (go as) + +-- | Unfold: create a vector of specified length, +-- by repeatedly applying a function to a starting value. +unfold :: forall n a. KnownNat n + => (a -> a) -- ^ Function to iterate. + -> a -- ^ Starting value. + -> V n a +unfold f a + = case Proxy @1 %<=? Proxy @n of + LE Refl -> let b = f a in b :. (unfold f b :: V (n-1) a) + NLE nle _ -> + case lt1_is_Zero @n nle of + Refl -> VNil + + +{-# COMPLETE V0 #-} +pattern V0 :: V 0 a +pattern V0 = VNil + +{-# COMPLETE V1 #-} +pattern V1 :: a -> V 1 a +pattern V1 x = x :. VNil + +{-# COMPLETE V2 #-} +pattern V2 :: a -> a -> V 2 a +pattern V2 x y = x :. y :. VNil + +{-# COMPLETE V3 #-} +pattern V3 :: a -> a -> a -> V 3 a +pattern V3 x y z = x :. y :. z :. VNil + +{-# COMPLETE V4 #-} +pattern V4 :: a -> a -> a -> a -> V 4 a +pattern V4 x y z w = x :. y :. z :. w :. VNil + +------------------------------------------------------------------ +-- products for vectors + +instance (KnownLength rs, Replicated n a rs) + => IsProduct (V n a) rs where + fromHList = fromHListVec replication + toHList = toHListVec replication + +data Replication n a rs where + NilReplication :: Replication 0 a '[] + ConsReplication :: Replication n a rs -> Replication (1+n) a (a ': rs) + +class ( rs ~ Replicate n a, KnownLength rs, n ~ Length rs ) + => Replicated n a rs | rs -> n where + replication :: Replication n a rs +instance Replicated 0 a '[] where + replication = NilReplication +instance (m ~ (1+n), rs ~ Replicate (m-1) a, (a ': rs) ~ Replicate m a, n ~ Length rs, Replicated n a rs) + => Replicated m a (a ': rs) where + replication = ConsReplication ( replication @n @a @rs ) + +fromHListVec :: Replication n a rs -> HList rs -> V n a +fromHListVec NilReplication _ = VNil +fromHListVec (ConsReplication repl) (x :> xs) = x :. fromHListVec repl xs + +toHListVec :: Replication n a rs -> V n a -> HList rs +toHListVec NilReplication _ = HNil +toHListVec (ConsReplication repl) (x :. xs) = x :> toHListVec repl xs +toHListVec (ConsReplication {}) _ = error "impossible" -- why?? + +instance GradedSemigroup (V 0 a) Nat where + type Grade Nat (V 0 a) i = V i a + type i :: j = i + j + () :: V i a -> V j a -> V (i+j) a + () VNil v = v + () (a:.as) v = a :. (as v) + +------------------------------------------------------------------ + +dim :: forall n. KnownNat n => Natural +dim = natVal ( Proxy @n ) + +------------------------------------------------------------------ +-- type classes for vector operations + +infixl 6 ^+^, ^-^ +infixl 7 ^.^, `dot`, ^×^, `cross` +infix 8 ^/, /^ +infix 8 ^*, *^ + + +-- | A semimodule is to a semiring as a module is to a ring. +-- +-- That is, a semimodule M over a semiring R consists of +-- +-- * a commutative monoid M, +-- * an action of R on M. +-- +-- The associated type family 'OfDim' is used to allow class methods +-- which involve elements in different dimensions. +-- This is crucial for the class methods for matrices (see the 'Matrix' type class) +class Semiring (Scalar v) => Semimodule d v | v -> d where + type Scalar v :: Type + type OfDim v d (n :: d) = (r :: Type) | r -> v d n + type ValidDim v d (n :: d) :: Constraint + {-# MINIMAL (^+^), ( (*^) | (^*) ) #-} + (^+^) :: ValidDim v d n => OfDim v d n -> OfDim v d n -> OfDim v d n + (*^) :: ValidDim v d n => Scalar v -> OfDim v d n -> OfDim v d n + (^*) :: ValidDim v d n => OfDim v d n -> Scalar v -> OfDim v d n + (*^) = flip (^*) + (^*) = flip (*^) + (^/) :: ( ValidDim v d n, DivisionRing (Scalar v) ) + => OfDim v d n -> Scalar v -> OfDim v d n + v ^/ a = v ^* recip a + (/^) :: ( ValidDim v d n, DivisionRing (Scalar v) ) + => Scalar v -> OfDim v d n -> OfDim v d n + (/^) = flip (^/) + +-- | A module M over a ring R consists of: +-- +-- * an abelian group M, +-- * an action of R on M. +-- +-- That is, we simply add additive inverses to the previous definition. +class (Ring (Scalar v), Semimodule d v) => LinearModule d v | v -> d where + {-# MINIMAL (^-^) | (-^) #-} + (^-^) :: ValidDim v d n => OfDim v d n -> OfDim v d n -> OfDim v d n + (^-^) x y = x ^+^ ((-^) y) + (-^) :: ValidDim v d n => OfDim v d n -> OfDim v d n + (-^) x = (-1) *^ x + +-- | Semimodule with an inner product. +-- +-- This usually consists of a non-degenerate symmetric bilinear form on the underlying semimodule. +-- +-- Other axioms might be more relevant depending on the underlying ring. +-- For instance, one instead insists on sesquilinearity over the field of complex numbers. +class Semimodule d v => Inner d v where + {-# MINIMAL ( (^.^) | dot ), normalise #-} + (^.^), dot :: ValidDim v d n => OfDim v d n -> OfDim v d n -> Scalar v + dot = (^.^) + (^.^) = dot + normalise :: ValidDim v d n => OfDim v d n -> OfDim v d n + +-- | Module with a cross product. +-- +-- This usually consists of a non-degenerate skew-symmetric bilinear multiplication satisfying the Jacobi identity. +-- Over the real numbers, this implies the dimension is 3. +class LinearModule d v => Cross d v where + type CrossDim v d (n :: d) :: Constraint + {-# MINIMAL (^×^) | cross #-} + (^×^), cross :: (ValidDim v d n, CrossDim v d n) => OfDim v d n -> OfDim v d n -> OfDim v d n + (^×^) = cross + cross = (^×^) + +------------------------------------------------------------------ +-- instances for plain vectors + +instance Semiring a => Semimodule Nat (V 0 a) where + type Scalar (V 0 a) = a + type OfDim (V 0 a) Nat n = V n a + type ValidDim (V 0 a) Nat n = KnownNat n + (^+^) = liftA2 (+) + v ^* k = fmap (*k) v + +instance Ring a => LinearModule Nat (V 0 a) where + (^-^) = liftA2 (-) + +instance (Semiring a, Floating a) => Inner Nat (V 0 a) where + (^.^) = (sum .) . liftA2 (*) + normalise v = invSqrt (dot v v) *^ v + +instance Ring a => Cross Nat (V 0 a) where + type CrossDim (V 0 a) Nat n = ( n ~ 3 ) + cross (V3 x y z) (V3 x' y' z') = V3 a b c + where a = y * z' - z * y' + b = z * x' - x * z' + c = x * y' - y * x' + +------------------------------------------------------------------ +-- derived operations + +-- | Angle between two vectors, computed using the inner product structure. +angle :: (Floating (Scalar v), ValidDim v d n, Inner d v) + => OfDim v d n -> OfDim v d n -> Scalar v +angle x y = acos $ dot (normalise x) (normalise y) + +-- | Norm of a vector, computed using the inner product. +norm :: (Floating (Scalar v), ValidDim v d n, Inner d v) + => OfDim v d n -> Scalar v +norm v = sqrt $ squaredNorm v + +-- | Squared norm of a vector, computed using the inner product. +squaredNorm :: (ValidDim v d n, Inner d v) + => OfDim v d n -> Scalar v +squaredNorm v = dot v v + +-- | Quadrance between two points. +quadrance :: (ValidDim v d n, LinearModule d v, Inner d v) + => OfDim v d n -> OfDim v d n -> Scalar v +quadrance x y = squaredNorm (x ^-^ y) + +-- | Distance between two points. +distance :: (Floating (Scalar v), ValidDim v d n, LinearModule d v, Inner d v) + => OfDim v d n -> OfDim v d n -> Scalar v +distance x y = norm (x ^-^ y) + +-- | Linear interpolation between two points. +along :: (ValidDim v d n, LinearModule d v) + => Scalar v -- ^ Interpolation coefficient. 0 = start, 1 = end. + -> OfDim v d n -- ^ Start. + -> OfDim v d n -- ^ End. + -> OfDim v d n +along t x y = (1-t) *^ x ^+^ t *^ y + +-- | Reflects a vector along a hyperplane, specified by a normal vector. +-- /Computes the normalisation of the normal vector in the process./ +reflect :: (Floating (Scalar v), ValidDim v d n, LinearModule d v, Inner d v) + => OfDim v d n -- ^ Vector to be reflected. + -> OfDim v d n -- ^ A normal vector of the reflecting hyperplane. + -> OfDim v d n +reflect v n = reflect' v (normalise n) + +-- | Same as 'reflect': reflects a vector along a hyperplane, specified by a normal vector. +-- However, /__this function assumes the given normal vector is already normalised__/. +reflect' :: (ValidDim v d n, LinearModule d v, Inner d v) + => OfDim v d n -- ^ Vector to be reflected. + -> OfDim v d n -- ^ /__Normalised__/ normal vector of the reflecting hyperplane. + -> OfDim v d n +reflect' v n = v ^-^ (2 * dot v n) *^ n + +-- | Projects the first argument onto the second. +proj :: (DivisionRing (Scalar v), ValidDim v d n, Inner d v) + => OfDim v d n -> OfDim v d n -> OfDim v d n +proj x y = projC x y *^ y + +-- | Projection constant: how far along the projection of the first vector lands along the second vector. +projC :: forall v d (n :: d). (DivisionRing (Scalar v), ValidDim v d n, Inner d v) + => OfDim v d n -> OfDim v d n -> Scalar v +projC x y = dot x y / dot y y + +-- | Orthogonality test. +-- +-- /__Uses a precise equality test, so use at your own risk with floating point numbers.__/ +isOrthogonal :: (ValidDim v d n, LinearModule d v, Inner d v, Eq (Scalar v)) + => OfDim v d n -> OfDim v d n -> Logic (Scalar v) +isOrthogonal v w = dot v w == 0 + +-- | Gram-Schmidt algorithm. +gramSchmidt :: (Floating (Scalar v), ValidDim v d n, LinearModule d v, Inner d v) + => [OfDim v d n] -> [OfDim v d n] +gramSchmidt [] = [] +gramSchmidt (x:xs) = x' : gramSchmidt (map (\v -> v ^-^ proj v x') xs) + where x' = normalise x + +-- | Rotate a vector around an axis (in dimension 3), with Rodrigues' formula. +rotateAroundAxis :: (Cross d v, Inner d v, Floating (Scalar v), ValidDim v d n, CrossDim v d n) + => OfDim v d n -- ^ Axis of rotation (a unit vector). + -> Scalar v -- ^ Angle of rotation, according to the right hand rule. + -> OfDim v d n -- ^ Vector to be rotated. + -> OfDim v d n +rotateAroundAxis n theta v = + cos theta *^ v ^+^ sin theta *^ (n ^×^ v) ^+^ ((1 - cos theta) * (n ^.^ v)) *^ n + +------------------------------------------------------------------ +-- specific implementation of matrices using nested vectors + +identityMat :: forall n a. (KnownNat n, Semiring a) => V n (V n a) +identityMat = buildV @n ( \ px1 -> buildV @n ( \ px2 -> indicator px1 px2 ) ) + where + indicator :: (KnownNat i, KnownNat j) => Proxy i -> Proxy j -> a + indicator px1 px2 = case sameNat px1 px2 of + Just _ -> 1 + _ -> 0 + +blockSum :: forall m1 m2 n1 n2 a. (KnownNat m1, KnownNat m2, KnownNat n1, KnownNat n2, Semiring a) + => V m1 (V n1 a)-> V m2 (V n2 a) -> V (m1+m2) (V (n1+n2) a) +blockSum mat1 mat2 = fmap ( pure zero) mat1 fmap (pure zero ) mat2 + +joinV :: V m (V n a) -> V (m * n) a +joinV VNil = VNil +joinV (col :. cols) = col joinV cols + +------------------------------------------------------------------ +-- matrix newtype + +-- | Matrix newtype. +-- +-- @M m n a@ denotes a matrix with @m@ rows and @n@ columns. +-- +-- This is represented as a vector of columns: column-major representation. +-- This choice is made for compatibility with SPIR-V, Vulkan, and OpenGL, +-- as all those frameworks represent matrices in column-major order. +newtype M m n a = M { unM :: V n (V m a) } + +deriving newtype instance Prelude.Eq a => Prelude.Eq (M m n a) +deriving newtype instance (KnownNat m, KnownNat n, Prelude.Ord a) => Prelude.Ord (M m n a) +deriving newtype instance (KnownNat m, KnownNat n, Eq a) => Eq (M m n a) +deriving newtype instance (KnownNat m, KnownNat n, Ord a) => Ord (M m n a) +deriving newtype instance (KnownNat m, KnownNat n, Show a) => Show (M m n a) +deriving via ( V n `Compose` V m ) + instance (KnownNat m, KnownNat n) => Functor (M m n) +deriving via ( V n `Compose` V m ) + instance (KnownNat m, KnownNat n) => Applicative (M m n) +deriving stock instance (KnownNat m, KnownNat n) => Foldable (M m n) +deriving stock instance (KnownNat m, KnownNat n) => Traversable (M m n) +deriving newtype instance (KnownNat m, KnownNat n, Binary a) => Binary (M m n a) +deriving newtype instance (KnownNat n, KnownNat m, Storable a) => Storable (M m n a) + + +------------------------------------------------------------------ +-- products for matrices + + +instance {-# OVERLAPPING #-} IsProduct (M 0 0 a) '[] where + fromHList _ = M VNil + toHList _ = HNil +instance {-# OVERLAPPABLE #-} IsProduct (M m 0 a) '[] where + fromHList _ = M VNil + toHList _ = HNil +instance {-# OVERLAPPABLE #-} KnownNat n => IsProduct (M 0 n a) '[] where + fromHList _ = M ( pure VNil ) + toHList _ = HNil +instance ( KnownNat m + , KnownNat n, 1 <= n + , Replicated (n-1) (V m a) rs + , KnownLength rs + , (Length rs + 1) ~ n + ) + => IsProduct (M m n a) (V m a ': rs) + where + fromHList (col :> cols) = M $ col :. (fromHListVec (replication @(n-1) @(V m a)) cols ) + toHList (M (col :. cols)) = col :> toHListVec (replication @(n-1) @(V m a)) cols + +instance ( KnownNat n, 1 <= n + , KnownNat m, 1 <= m + , Replicated (m*n-1) a rs + , Length rs ~ (n*m-1), (1 + Length rs) ~ (n*m) + , 1 <= (n*m) + , Replicate (n*m) a ~ (a ': rs) -- type checker unfortunately can't deduce this + ) + => IsProduct (M m n a) (a ': rs) + where + toHList = toHList . joinV . unM + fromHList = M . splitCols . fromHList + +splitCols + :: forall (n :: Nat) (m :: Nat) (a :: Type) + . ( KnownNat n, KnownNat m ) + => V (m*n) a -> V n (V m a) +splitCols v = case Proxy @1 %<=? Proxy @n of + NLE nle Refl -> + case lt1_is_Zero @n nle of + Refl -> VNil + LE Refl -> + case splitAtV @m v of + ( col, next ) -> + col :. splitCols @(n-1) next + +instance KnownNat m => GradedSemigroup (M m 0 a) Nat where + type Grade Nat (M m 0 a) i = M m i a + type i :: j = i + j + () :: M m i a -> M m j a -> M m (i+j) a + (M cs) (M ds) = M ( cs ds ) + +------------------------------------------------------------------ +-- type classes for matrix operations + +infixl 6 !+!, !-! +infixl 7 !*! +infix 8 !*^, ^*! +infix 9 *!, !* + +type family VectorOf m :: Type + +-- | Typeclass for matrix operations. +-- +-- The 'OfDims' associated type family allows the type class methods to involve various dimension indices. +class LinearModule d (VectorOf m) => Matrix d m | m -> d where + type OfDims m d (ij :: (d, d)) = r | r -> m ij + identity :: ValidDim (VectorOf m) d i => OfDims m d '(i,i) + diag :: ValidDim (VectorOf m) d i => Scalar (VectorOf m) -> OfDims m d '(i,i) + inverse :: ValidDim (VectorOf m) d i => OfDims m d '(i,i) -> OfDims m d '(i,i) + determinant :: ValidDim (VectorOf m) d i => OfDims m d '(i,i) -> Scalar (VectorOf m) + transpose :: ( ValidDim (VectorOf m) d i + , ValidDim (VectorOf m) d j + ) + => OfDims m d '(i,j) -> OfDims m d '(j,i) + + (!+!) :: ( ValidDim (VectorOf m) d i + , ValidDim (VectorOf m) d j + ) + => OfDims m d '(i,j) -> OfDims m d '(i,j) -> OfDims m d '(i,j) + (!-!) :: ( ValidDim (VectorOf m) d i + , ValidDim (VectorOf m) d j + ) + => OfDims m d '(i,j) -> OfDims m d '(i,j) -> OfDims m d '(i,j) + konst :: ( ValidDim (VectorOf m) d i + , ValidDim (VectorOf m) d j + ) + => Scalar (VectorOf m) -> OfDims m d '(i,j) + (*!) :: ( ValidDim (VectorOf m) d i + , ValidDim (VectorOf m) d j + ) + => Scalar (VectorOf m) -> OfDims m d '(i,j) -> OfDims m d '(i,j) + (!*) :: ( ValidDim (VectorOf m) d i + , ValidDim (VectorOf m) d j + ) + => OfDims m d '(i,j) -> Scalar (VectorOf m) -> OfDims m d '(i,j) + (!*^) :: ( ValidDim (VectorOf m) d i + , ValidDim (VectorOf m) d j + ) + => OfDims m d '(i,j) -> OfDim (VectorOf m) d j -> OfDim (VectorOf m) d i + (^*!) :: ( ValidDim (VectorOf m) d i + , ValidDim (VectorOf m) d j + ) + => OfDim (VectorOf m) d i -> OfDims m d '(i,j) -> OfDim (VectorOf m) d j + (!*!) :: ( ValidDim (VectorOf m) d i + , ValidDim (VectorOf m) d j + , ValidDim (VectorOf m) d k + ) + => OfDims m d '(i,j) -> OfDims m d '(j,k) -> OfDims m d '(i,k) + identity = diag 1 + (*!) = flip (!*) -- SPIR-V defines MatrixTimesScalar + +type instance VectorOf (M 0 0 a) = V 0 a + +instance Ring a => Matrix Nat (M 0 0 a) where + type OfDims (M 0 0 a) Nat '(i,j) = M i j a + identity = M identityMat + diag a = a *! identity + transpose (M m) = M ( distribute m ) + (M m1) !+! (M m2) = M $ liftA2 ( liftA2 (+) ) m1 m2 + (M m1) !-! (M m2) = M $ liftA2 ( liftA2 (-) ) m1 m2 + konst = M . pure . pure + (M m) !* a = M $ liftA2 ( liftA2 (*) ) ka m + where M ka = konst a + v ^*! (M m) = fmap (\col -> sum $ liftA2 (*) v col) m + m !*^ v = v ^*! transpose m + (M m) !*! (M n) = M $ fmap (\col -> fmap (sum . liftA2 (*) col) mt) n + where mt = distribute m + determinant = error "determinant: not implemented" + inverse = error "inverse matrix: not implemented" + +------------------------------------------------------------------ +-- utility 4x4 matrices for camera viewpoints in 3D + +-- | Affine 3D transformation matrix for a perspective view. +-- (Adapted from Edward Kmett's __Linear__ library for the Vulkan coordinate system.) +perspective + :: Floating a + => a -- ^ FOV. + -> a -- ^ Aspect ratio. + -> a -- ^ Near plane. + -> a -- ^ Far plane. + -> M 4 4 a +perspective fovy aspect near far + = M $ V4 (V4 x 0 0 0) + (V4 0 y 0 0) + (V4 0 0 z 1) + (V4 0 0 w 0) + where tanHalfFovy = tan $ fovy / 2 + x = 1 / (aspect * tanHalfFovy) + y = 1 / tanHalfFovy + z = far / (far - near) + w = far * near / (near - far) + +-- | Affine 3D transformation matrix for looking at focus point from a given view point. +-- (Adapted from Edward Kmett's __Linear__ library for the Vulkan coordinate system.) +lookAt + :: forall a. Floating a + => V 3 a -- ^ Focus point. + -> V 3 a -- ^ View point. + -> V 3 a -- ^ Up vector. + -> M 4 4 a +lookAt focus viewPoint up + = M $ () + ( distribute ( V4 xa ya za (pure 0) ) ) + ( V1 (V4 (-xd) (-yd) (-zd) 1) ) + where za = normalise (focus ^-^ viewPoint) + xa = normalise (za `cross` up) + ya = za `cross` xa + xd = xa ^.^ focus + yd = ya ^.^ focus + zd = za ^.^ focus diff --git a/src/Math/Logic/Bits.hs b/src/Math/Logic/Bits.hs new file mode 100644 --- /dev/null +++ b/src/Math/Logic/Bits.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Math.Logic.Bits + +Alternative "Data.Bits" type class tailored for this library. + +Justification: some of the methods of "Data.Bits" are unsuited for this library. +Consider for instance the class method + +> shiftL :: a -> Int -> a + +This function bakes in the type `Int`. +For this library, this would mean that only shifts +by Haskell-level constants are possible. +Instead, we want something which can instantiate to, e.g.: + +> shiftL :: AST Word64 -> AST Word8 -> AST Word64 + +See also "Math.Algebra.Class" for further explanations +regarding the limitations of the standard type classes. + +-} + +module Math.Logic.Bits + ( Bits(..) + , BitShift(..) + , BitCast(..) + , zipBits2 + ) + where + +-- base +import Prelude + ( Int, Word ) +import qualified Prelude +import qualified Data.Bits as Base +import Foreign.C.Types +import GHC.Float + ( castWord32ToFloat , castFloatToWord32 + , castWord64ToDouble, castDoubleToWord64 + ) + +-- half +import Numeric.Half + ( Half(..) ) + +-- fir +import Deriving.Base + ( Base(..) ) -- newtype for deriving via base instances +import FIR.Prelude +import Math.Algebra.Class + ( Integral ) + +---------------------------------------------------------------------- + +infixl 7 .&. +infixl 5 .|. +infixl 6 `xor` + +class Bits a where + (.&.) :: a -> a -> a + (.|.) :: a -> a -> a + xor :: a -> a -> a + complement :: a -> a + zeroBits :: a + -- | Reverse the order of the bits. + bitReverse :: a -> a + +instance Base.FiniteBits a => Bits (Base a) where + (.&.) = coerce ( (Base..&.) :: a -> a -> a) + (.|.) = coerce ( (Base..|.) :: a -> a -> a) + xor = coerce ( Base.xor :: a -> a -> a) + complement = coerce (Base.complement :: a -> a) + zeroBits = coerce (Base.zeroBits :: a) + bitReverse = coerce ( reverseBits :: a -> a ) + where + reverseBits :: a -> a + reverseBits x = + Prelude.foldr + ( \ i acc -> if Base.testBit x i then Base.setBit acc ( n Prelude.- 1 Prelude.- i ) else acc ) + Base.zeroBits + [ 0 .. n Prelude.- 1 ] + where + n = Base.finiteBitSize x + +deriving via Base Bool instance Bits Bool +deriving via Base Word8 instance Bits Word8 +deriving via Base Word16 instance Bits Word16 +deriving via Base Word32 instance Bits Word32 +deriving via Base Word64 instance Bits Word64 +deriving via Base Word instance Bits Word +deriving via Base Int8 instance Bits Int8 +deriving via Base Int16 instance Bits Int16 +deriving via Base Int32 instance Bits Int32 +deriving via Base Int64 instance Bits Int64 +deriving via Base Int instance Bits Int + +deriving via Base CChar instance Bits CChar +deriving via Base CSChar instance Bits CSChar +deriving via Base CUChar instance Bits CUChar +deriving via Base CShort instance Bits CShort +deriving via Base CUShort instance Bits CUShort +deriving via Base CInt instance Bits CInt +deriving via Base CUInt instance Bits CUInt +deriving via Base CLong instance Bits CLong +deriving via Base CULong instance Bits CULong +deriving via Base CLLong instance Bits CLLong +deriving via Base CULLong instance Bits CULLong + +type family BitsType (bs :: (Type,Type)) :: Type where + BitsType '(b,_) = b +type family ShiftType (bs :: (Type,Type)) :: Type where + ShiftType '(_,b) = b + +-- | Bit-shift operations. +class (bs ~ '(BitsType bs, ShiftType bs)) => BitShift (bs :: (Type,Type)) where + -- | Shift the first argument left by the specified number of bits. + -- + -- Ignores the sign of the shift argument (second argument). + -- + -- This is a logical shift: least-significant bits are set to 0. + shiftL :: BitsType bs -> ShiftType bs -> BitsType bs + -- | Shift the first argument right by the specified number of bits. + -- + -- Ignores the sign of the shift argument (second argument). + -- + -- For signed types this is an arithmetic shift (most-significant bits + -- are filled with the sign of the first argument), and for unsigned + -- types a logical shift (most-significant bits are set to 0), + -- as with 'Data.Bits.shiftR'. + shiftR :: BitsType bs -> ShiftType bs -> BitsType bs + +instance (Base.Bits a, Prelude.Integral i) + => BitShift '(Base a,i) where + shiftL (Base a) i = Base $ Base.shiftL a (Prelude.fromIntegral i) + shiftR (Base a) i = Base $ Base.shiftR a (Prelude.fromIntegral i) + +deriving via '(Base Word8 ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Word8 ,s) +deriving via '(Base Word16,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Word16,s) +deriving via '(Base Word32,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Word32,s) +deriving via '(Base Word64,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Word64,s) +deriving via '(Base Word ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Word ,s) +deriving via '(Base Int8 ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Int8 ,s) +deriving via '(Base Int16 ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Int16 ,s) +deriving via '(Base Int32 ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Int32 ,s) +deriving via '(Base Int64 ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Int64 ,s) +deriving via '(Base Int ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(Int ,s) + +deriving via '(Base CChar ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CChar ,s) +deriving via '(Base CSChar ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CSChar ,s) +deriving via '(Base CUChar ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CUChar ,s) +deriving via '(Base CShort ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CShort ,s) +deriving via '(Base CUShort,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CUShort,s) +deriving via '(Base CInt ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CInt ,s) +deriving via '(Base CUInt ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CUInt ,s) +deriving via '(Base CLong ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CLong ,s) +deriving via '(Base CULong ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CULong ,s) +deriving via '(Base CLLong ,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CLLong ,s) +deriving via '(Base CULLong,(s :: Type)) instance (Integral s, Prelude.Integral s) => BitShift '(CULLong,s) + +-- | Reinterpret the bits of a value as a value of another type of the same width, +-- e.g. a 'Float' as the 'Word32' with the same bit pattern, or a signed integer as the +-- unsigned integer with the same two's complement representation. +class BitCast a b where + bitcast :: a -> b + +instance BitCast Word8 Int8 where + bitcast = Prelude.fromIntegral +instance BitCast Word16 Int16 where + bitcast = Prelude.fromIntegral +instance BitCast Word32 Int32 where + bitcast = Prelude.fromIntegral +instance BitCast Word64 Int64 where + bitcast = Prelude.fromIntegral +instance BitCast Int8 Word8 where + bitcast = Prelude.fromIntegral +instance BitCast Int16 Word16 where + bitcast = Prelude.fromIntegral +instance BitCast Int32 Word32 where + bitcast = Prelude.fromIntegral +instance BitCast Int64 Word64 where + bitcast = Prelude.fromIntegral + +instance BitCast Word16 Half where + bitcast = coerce +instance BitCast Word32 Float where + bitcast = castWord32ToFloat +instance BitCast Word64 Double where + bitcast = castWord64ToDouble +instance BitCast Half Word16 where + bitcast = coerce +instance BitCast Float Word32 where + bitcast = castFloatToWord32 +instance BitCast Double Word64 where + bitcast = castDoubleToWord64 +instance BitCast Int16 Half where + bitcast = coerce . ( Prelude.fromIntegral :: Int16 -> Word16 ) +instance BitCast Int32 Float where + bitcast = castWord32ToFloat . ( Prelude.fromIntegral :: Int32 -> Word32 ) +instance BitCast Int64 Double where + bitcast = castWord64ToDouble . ( Prelude.fromIntegral :: Int64 -> Word64 ) +instance BitCast Half Int16 where + bitcast = ( Prelude.fromIntegral :: Word16 -> Int16 ) . coerce +instance BitCast Float Int32 where + bitcast = ( Prelude.fromIntegral :: Word32 -> Int32 ) . castFloatToWord32 +instance BitCast Double Int64 where + bitcast = ( Prelude.fromIntegral :: Word64 -> Int64 ) . castDoubleToWord64 + +zipBits2 :: Bits a + => (Bool -> Bool -> Bool) + -> (a -> a -> a ) +zipBits2 f + = case ( f False False, f False True, f True False, f True True ) of + ( False, False, False, False ) -> \ _ _ -> zeroBits + ( False, False, False, True ) -> (.&.) + ( False, False, True , False ) -> \ x y -> x .&. complement y + ( False, False, True , True ) -> \ x _ -> x + ( False, True , False, False ) -> \ x y -> complement x .&. y + ( False, True , False, True ) -> \ _ y -> y + ( False, True , True , False ) -> xor + ( False, True , True , True ) -> (.|.) + ( True , False, False, False ) -> \ x y -> complement ( x .|. y ) + ( True , False, False, True ) -> \ x y -> complement ( x `xor` y ) + ( True , False, True , False ) -> \ _ y -> complement y + ( True , False, True , True ) -> \ x y -> x .|. complement y + ( True , True , False, False ) -> \ x _ -> complement x + ( True , True , False, True ) -> \ x y -> complement x .|. y + ( True , True , True , False ) -> \ x y -> complement ( x .&. y ) + ( True , True , True , True ) -> \ _ _ -> complement zeroBits diff --git a/src/Math/Logic/Class.hs b/src/Math/Logic/Class.hs new file mode 100644 --- /dev/null +++ b/src/Math/Logic/Class.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Math.Logic.Class + +This module overloads logical functionalities so that they can be used to manipulate ASTs: + + * overloaded boolen operations such as @&&@, @||@, @xor@... + * overloaded if-then-else for use with @RebindableSyntax@, + * alternative @Eq@ and @Ord@ type classes which allow overloading with ASTs. +-} + +module Math.Logic.Class where + +-- base +import Prelude + ( Int, Word, Foldable(..) ) +import qualified Prelude +import Foreign.C.Types +import qualified GHC.Stack + ( HasCallStack ) + +-- fir +import Deriving.Base + ( Base(..) ) -- newtype for deriving via base instances +import FIR.Prelude + +---------------------------------------------------------------------- + +infixr 3 && +infixr 2 || + +class Boolean b where + true :: b + false :: b + (&&) :: b -> b -> b + (||) :: b -> b -> b + not :: b -> b + +instance Boolean Bool where + true = True + false = False + (&&) = (Prelude.&&) + (||) = (Prelude.||) + not = Prelude.not + +infix 4 == +infix 4 /= + +type family Choosing b (t :: (Type,Type,Type)) = r | r -> b t where + Choosing b '(x,y,z) = b -> x -> y -> z + +class Boolean b => Choose b (t :: (Type,Type,Type)) where + choose :: Choosing b t + +ifThenElse :: (GHC.Stack.HasCallStack, Choose b (t :: (Type,Type,Type))) + => Choosing b t +ifThenElse = choose + +instance (x ~ y, x ~ z) => Choose Bool '(x,y,z) where + choose True x _ = x + choose False _ y = y + +class Boolean (Logic a) => Eq a where + type Logic a + (==) :: a -> a -> Logic a + (/=) :: a -> a -> Logic a + a /= b = not (a == b) + +instance Prelude.Eq a => Eq (Base a) where + type Logic (Base a) = Bool + (==) = coerce ( (Prelude.==) :: a -> a -> Bool ) + (/=) = coerce ( (Prelude./=) :: a -> a -> Bool ) + +deriving via Base () instance Eq () +deriving via Base Bool instance Eq Bool +deriving via Base Word8 instance Eq Word8 +deriving via Base Word16 instance Eq Word16 +deriving via Base Word32 instance Eq Word32 +deriving via Base Word64 instance Eq Word64 +deriving via Base Word instance Eq Word +deriving via Base Int8 instance Eq Int8 +deriving via Base Int16 instance Eq Int16 +deriving via Base Int32 instance Eq Int32 +deriving via Base Int64 instance Eq Int64 +deriving via Base Int instance Eq Int +deriving via Base Half instance Eq Half +deriving via Base Float instance Eq Float +deriving via Base Double instance Eq Double + +deriving via Base CChar instance Eq CChar +deriving via Base CSChar instance Eq CSChar +deriving via Base CUChar instance Eq CUChar +deriving via Base CShort instance Eq CShort +deriving via Base CUShort instance Eq CUShort +deriving via Base CInt instance Eq CInt +deriving via Base CUInt instance Eq CUInt +deriving via Base CLong instance Eq CLong +deriving via Base CULong instance Eq CULong +deriving via Base CLLong instance Eq CLLong +deriving via Base CULLong instance Eq CULLong +deriving via Base CFloat instance Eq CFloat +deriving via Base CDouble instance Eq CDouble + + +newtype All b = All { getAll :: b } +newtype Any b = Any { getAny :: b } + +instance Boolean b => Semigroup (All b) where + (<>) = coerce ( (&&) @b ) +instance Boolean b => Monoid (All b) where + mempty = coerce ( true @b ) + +instance Boolean b => Semigroup (Any b) where + (<>) = coerce ( (||) @b ) +instance Boolean b => Monoid (Any b) where + mempty = coerce (false @b) + +-- from Data.Functor.Utils +{-# INLINE (#.) #-} +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) +(#.) _f = coerce + +and :: (Foldable t, Boolean b) => t b -> b +and = getAll #. foldMap All + +or :: (Foldable t, Boolean b) => t b -> b +or = getAny #. foldMap Any + +any :: (Foldable t, Boolean b) => (a -> b) -> t a -> b +any p = getAny #. foldMap (Any #. p) + +all :: (Foldable t, Boolean b) => (a -> b) -> t a -> b +all p = getAll #. foldMap (All #. p) + +infix 4 <= +infix 4 < +infix 4 >= +infix 4 > + +class Eq a => Ord a where + --type Ordering a + --compare :: a -> a -> Ordering a + (<=) :: a -> a -> Logic a + (>=) :: a -> a -> Logic a + (<) :: a -> a -> Logic a + (>) :: a -> a -> Logic a + max :: a -> a -> a + min :: a -> a -> a + + (>=) = flip (<=) + (>) = flip (<) + + +instance Prelude.Ord a => Ord (Base a) where + (<=) = coerce ( (Prelude.<=) :: a -> a -> Bool ) + (>=) = coerce ( (Prelude.>=) :: a -> a -> Bool ) + (<) = coerce ( (Prelude.<) :: a -> a -> Bool ) + (>) = coerce ( (Prelude.>) :: a -> a -> Bool ) + max = coerce ( Prelude.max :: a -> a -> a ) + min = coerce ( Prelude.min :: a -> a -> a ) + +deriving via Base () instance Ord () +deriving via Base Bool instance Ord Bool +deriving via Base Word8 instance Ord Word8 +deriving via Base Word16 instance Ord Word16 +deriving via Base Word32 instance Ord Word32 +deriving via Base Word64 instance Ord Word64 +deriving via Base Word instance Ord Word +deriving via Base Int8 instance Ord Int8 +deriving via Base Int16 instance Ord Int16 +deriving via Base Int32 instance Ord Int32 +deriving via Base Int64 instance Ord Int64 +deriving via Base Int instance Ord Int +deriving via Base Half instance Ord Half +deriving via Base Float instance Ord Float +deriving via Base Double instance Ord Double + +deriving via Base CChar instance Ord CChar +deriving via Base CSChar instance Ord CSChar +deriving via Base CUChar instance Ord CUChar +deriving via Base CShort instance Ord CShort +deriving via Base CUShort instance Ord CUShort +deriving via Base CInt instance Ord CInt +deriving via Base CUInt instance Ord CUInt +deriving via Base CLong instance Ord CLong +deriving via Base CULong instance Ord CULong +deriving via Base CLLong instance Ord CLLong +deriving via Base CULLong instance Ord CULLong +deriving via Base CFloat instance Ord CFloat +deriving via Base CDouble instance Ord CDouble diff --git a/src/Math/Quaternion.hs b/src/Math/Quaternion.hs new file mode 100644 --- /dev/null +++ b/src/Math/Quaternion.hs @@ -0,0 +1,137 @@ +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: Math.Quaternion + +Bare-bones implementation of quaternions, +together with a few simple operations +such as the conjugation action of quaternions on 3-d vectors. + +-} + +module Math.Quaternion where + +-- base +import Prelude + ( Eq(..), Show(..), Functor(..), Applicative(..) + , Foldable(..), Traversable(..) ) +import Control.Applicative + ( liftA2 ) + +-- fir +import FIR.Prelude +import Math.Algebra.Class + ( AdditiveMonoid(..), CancellativeAdditiveMonoid(..), AdditiveGroup(..) + , Semiring(..), Ring, DivisionRing(..) + , Signed(..), Floating(..) + ) +import Math.Linear + ( V(..), M(M) + , pattern V3 + , pattern V4 + , Semimodule(..), LinearModule(..), Inner(..), Cross(..) + , norm, normalise + ) + +---------------------------------------------------------------------------- + +newtype Quaternion a = Quaternion { quaternion :: V 4 a } + deriving stock ( Eq, Show, Foldable, Traversable ) + deriving newtype ( Functor, Applicative ) + +instance Semiring a => Semimodule () (Quaternion a) where + type Scalar (Quaternion a) = a + type OfDim (Quaternion a) () '() = Quaternion a + type ValidDim (Quaternion a) () unit = ( unit ~ '() ) + (^+^) = coerce ( (^+^) :: V 4 a -> V 4 a -> V 4 a ) + (*^) = coerce ( (*^) :: a -> V 4 a -> V 4 a ) + +instance Ring a => LinearModule () (Quaternion a) where + (^-^) = coerce ( (^-^) :: V 4 a -> V 4 a -> V 4 a ) + (-^) = coerce ( ( -^) :: V 4 a -> V 4 a ) + +instance (Semiring a, Floating a) => Inner () (Quaternion a) where + dot = coerce ( dot :: V 4 a -> V 4 a -> a ) + normalise = coerce ( normalise :: V 4 a -> V 4 a ) + +instance AdditiveMonoid a => AdditiveMonoid (Quaternion a) where + (+) = liftA2 (+) + zero = Quaternion (pure zero) + fromInteger = Quaternion . ( :. pure zero ) . fromInteger + +instance Ring a => Semiring (Quaternion a) where + Quaternion { quaternion = V4 xr xi xj xk } * Quaternion { quaternion = V4 yr yi yj yk } + = Quaternion $ + V4 (xr*yr - xi*yi - xj*yj - xk*yk) + (xr*yi + xi*yr + xj*yk - xk*yj) + (xr*yj + xj*yr + xk*yi - xi*yk) + (xr*yk + xk*yr + xi*yj - xj*yi) + +instance CancellativeAdditiveMonoid a => CancellativeAdditiveMonoid (Quaternion a) where + (-) = liftA2 (-) + +instance AdditiveGroup a => AdditiveGroup (Quaternion a) where + negate = fmap negate + +instance Floating a => Signed (Quaternion a) where + abs q = norm q *^ Quaternion (V4 1 0 0 0) + signum q = recip (norm q) *^ q + +instance ( DivisionRing a, Floating a ) => DivisionRing (Quaternion a) where + recip a = recip (norm a) *^ conjugate a + fromRational = Quaternion . ( :. pure zero ) . fromRational + +conjugate :: Ring a => Quaternion a -> Quaternion a +conjugate (Quaternion (a :. v)) = Quaternion (a :. (-^) @_ @_ @3 v) + +-- 'rotate' expects the quaternion to be of unit norm +rotate :: Ring a => Quaternion a -> V 3 a -> V 3 a +rotate q v = ijk where + Quaternion (_ :. ijk) = q * Quaternion (0 :. v) * conjugate q + +axisAngle :: ( Semiring a, Floating a ) => V 3 a -> a -> Quaternion a +axisAngle axis theta = Quaternion ( cos half :. sin half *^ normalise axis ) + where half = 0.5 * theta + +-- | The shortest rotation from one vector to another. +rotationFromTo :: ( Floating a, Eq a ) => V 3 a -> V 3 a -> Quaternion a +rotationFromTo u v + | w == 0 + = error "rotationFromTo: opposite directions" + | otherwise + = normalise ( Quaternion ( w :. cross u' v' ) ) + where + u' = normalise u + v' = normalise v + w = 1 + dot u' v' + +fromQuaternion :: Ring a => Quaternion a -> M 3 3 a +fromQuaternion (Quaternion (V4 w x y z)) + = M $ V3 (V3 (1-2*(y2+z2)) (2*(xy+zw)) (2*(xz-yw))) + (V3 (2*(xy-zw)) (1-2*(x2+z2)) (2*(yz+xw))) + (V3 (2*(xz+yw)) (2*(yz-xw)) (1-2*(x2+y2))) + where x2 = x*x + y2 = y*y + z2 = z*z + xy = x*y + xz = x*z + xw = x*w + yz = y*z + yw = y*w + zw = z*w diff --git a/src/SPIRV/Builtin.hs b/src/SPIRV/Builtin.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Builtin.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module: SPIRV.Builtin + +Enumeration of SPIR-V built-in variables. Used both at the type-level and value-level. + +See the SPIR-V specification, section 3.21 __BuiltIn__. + +Refer to "FIR.BuiltIn" for usage in this library. + +-} + +module SPIRV.Builtin + ( Builtin(..) + , readBuiltin + ) + where + +-- base +import Data.Word + ( Word32 ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- fir +import Data.Binary.Class.Put + ( Put(..) ) +import Data.Type.Known + ( Demotable(Demote), Known(known) ) + +-------------------------------------------------- + +data Builtin + = Position + | PointSize + -- + | ClipDistance + | CullDistance + | VertexId + | InstanceId + | PrimitiveId + | InvocationId + | Layer + | ViewportIndex + | TessLevelOuter + | TessLevelInner + | TessCoord + | PatchVertices + | FragCoord + | PointCoord + | FrontFacing + | SampleId + | SamplePosition + | SampleMask + -- + | FragDepth + | HelperInvocation + | NumWorkgroups + | WorkgroupSize + | WorkgroupId + | LocalInvocationId + | GlobalInvocationId + | LocalInvocationIndex + | WorkDim + | GlobalSize + | EnqueuedWorkgroupSize + | GlobalOffset + | GlobalLinearId + -- + | SubgroupSize + | SubgroupMaxSize + | NumSubgroups + | NumEnqueuedSubgroups + | SubgroupId + | SubgroupLocalInvocationId + | VertexIndex + | InstanceIndex + -- + | LaunchID + | LaunchSize + | WorldRayOrigin + | WorldRayDirection + | ObjectRayOrigin + | ObjectRayDirection + | RayTMin + | RayTMax + | InstanceCustomIndex + | ObjectToWorld + | WorldToObject +-- | HitT -- this only exists in the NV ray tracing extension, before it became an alias of RayTMax + | HitKind + | IncomingRayFlags + | RayGeometryIndex + deriving stock ( Show, Eq, Ord ) + +readBuiltin :: ShortText -> Maybe Builtin +readBuiltin "gl_Position" = Just Position +readBuiltin "gl_PointSize" = Just PointSize +readBuiltin "gl_ClipDistance" = Just ClipDistance +readBuiltin "gl_CullDistance" = Just CullDistance +readBuiltin "gl_VertexID" = Just VertexId +readBuiltin "gl_InstanceID" = Just InstanceId +readBuiltin "gl_PrimitiveID" = Just PrimitiveId +readBuiltin "gl_InvocationID" = Just InvocationId +readBuiltin "gl_Layer" = Just Layer +readBuiltin "gl_ViewportIndex" = Just ViewportIndex +readBuiltin "gl_TessLevelOuter" = Just TessLevelOuter +readBuiltin "gl_TessLevelInner" = Just TessLevelInner +readBuiltin "gl_TessCoord" = Just TessCoord +readBuiltin "gl_PatchVertices" = Just PatchVertices +readBuiltin "gl_FragCoord" = Just FragCoord +readBuiltin "gl_PointCoord" = Just PointCoord +readBuiltin "gl_FrontFacing" = Just FrontFacing +readBuiltin "gl_SampleID" = Just SampleId +readBuiltin "gl_SamplePosition" = Just SamplePosition +readBuiltin "gl_SampleMask" = Just SampleMask +readBuiltin "gl_FragDepth" = Just FragDepth +readBuiltin "gl_HelperInvocation" = Just HelperInvocation +readBuiltin "gl_NumWorkgroups" = Just NumWorkgroups +readBuiltin "gl_WorkgroupSize" = Just WorkgroupSize +readBuiltin "gl_WorkgroupID" = Just WorkgroupId +readBuiltin "gl_LocalInvocationID" = Just LocalInvocationId +readBuiltin "gl_GlobalInvocationID" = Just GlobalInvocationId +readBuiltin "gl_LocalInvocationIndex" = Just LocalInvocationIndex +readBuiltin "gl_WorkDim" = Just WorkDim +readBuiltin "gl_GlobalSize" = Just GlobalSize +readBuiltin "gl_EnqueuedWorkgroupSize" = Just EnqueuedWorkgroupSize +readBuiltin "gl_GlobalOffset" = Just GlobalOffset +readBuiltin "gl_GlobalLinearID" = Just GlobalLinearId +readBuiltin "gl_SubgroupSize" = Just SubgroupSize +readBuiltin "gl_SubgroupMaxSize" = Just SubgroupMaxSize +readBuiltin "gl_NumSubgroups" = Just NumSubgroups +readBuiltin "gl_NumEnqueuedSubgroups" = Just NumEnqueuedSubgroups +readBuiltin "gl_SubgroupID" = Just SubgroupId +readBuiltin "gl_SubgroupInvocationID" = Just SubgroupLocalInvocationId +readBuiltin "gl_VertexIndex" = Just VertexIndex +readBuiltin "gl_InstanceIndex" = Just InstanceIndex +readBuiltin "cl_WorkDim" = Just WorkDim +readBuiltin "cl_GlobalSize" = Just GlobalSize +readBuiltin "cl_GlobalInvocationID" = Just GlobalInvocationId +readBuiltin "cl_LocalInvocationID" = Just LocalInvocationId +readBuiltin "cl_NumWorkgroups" = Just NumWorkgroups +readBuiltin "cl_WorkgroupID" = Just WorkgroupId +readBuiltin "cl_GlobalOffset" = Just GlobalOffset +readBuiltin "cl_GlobalLinearID" = Just GlobalLinearId +readBuiltin "gl_LaunchID" = Just LaunchID +readBuiltin "gl_LaunchSize" = Just LaunchSize +readBuiltin "gl_WorldRayOrigin" = Just WorldRayOrigin +readBuiltin "gl_WorldRayDirection" = Just WorldRayDirection +readBuiltin "gl_ObjectRayOrigin" = Just ObjectRayOrigin +readBuiltin "gl_ObjectRayDirection" = Just ObjectRayDirection +readBuiltin "gl_RayTMin" = Just RayTMin +readBuiltin "gl_RayTMax" = Just RayTMax +readBuiltin "gl_InstanceCustomIndex" = Just InstanceCustomIndex +readBuiltin "gl_ObjectToWorld" = Just ObjectToWorld +readBuiltin "gl_WorldToObject" = Just WorldToObject +readBuiltin "gl_HitT" = Just RayTMax -- NOT "HitT" which only exists in the NV extension +readBuiltin "gl_HitKind" = Just HitKind +readBuiltin "gl_IncomingRayFlags" = Just IncomingRayFlags +readBuiltin "gl_RayGeometryIndex" = Just RayGeometryIndex +readBuiltin _ = Nothing + +instance Put Builtin where + wordCount _ = 1 + + put Position = put @Word32 0 + put PointSize = put @Word32 1 + -- + put ClipDistance = put @Word32 3 + put CullDistance = put @Word32 4 + put VertexId = put @Word32 5 + put InstanceId = put @Word32 6 + put PrimitiveId = put @Word32 7 + put InvocationId = put @Word32 8 + put Layer = put @Word32 9 + put ViewportIndex = put @Word32 10 + put TessLevelOuter = put @Word32 11 + put TessLevelInner = put @Word32 12 + put TessCoord = put @Word32 13 + put PatchVertices = put @Word32 14 + put FragCoord = put @Word32 15 + put PointCoord = put @Word32 16 + put FrontFacing = put @Word32 17 + put SampleId = put @Word32 18 + put SamplePosition = put @Word32 19 + put SampleMask = put @Word32 20 + -- + put FragDepth = put @Word32 22 + put HelperInvocation = put @Word32 23 + put NumWorkgroups = put @Word32 24 + put WorkgroupSize = put @Word32 25 + put WorkgroupId = put @Word32 26 + put LocalInvocationId = put @Word32 27 + put GlobalInvocationId = put @Word32 28 + put LocalInvocationIndex = put @Word32 29 + put WorkDim = put @Word32 30 + put GlobalSize = put @Word32 31 + put EnqueuedWorkgroupSize = put @Word32 32 + put GlobalOffset = put @Word32 33 + put GlobalLinearId = put @Word32 34 + -- + put SubgroupSize = put @Word32 36 + put SubgroupMaxSize = put @Word32 37 + put NumSubgroups = put @Word32 38 + put NumEnqueuedSubgroups = put @Word32 39 + put SubgroupId = put @Word32 40 + put SubgroupLocalInvocationId = put @Word32 41 + put VertexIndex = put @Word32 42 + put InstanceIndex = put @Word32 43 +-- + put LaunchID = put @Word32 5319 + put LaunchSize = put @Word32 5320 + put WorldRayOrigin = put @Word32 5321 + put WorldRayDirection = put @Word32 5322 + put ObjectRayOrigin = put @Word32 5323 + put ObjectRayDirection = put @Word32 5324 + put RayTMin = put @Word32 5325 + put RayTMax = put @Word32 5326 + put InstanceCustomIndex = put @Word32 5327 + put ObjectToWorld = put @Word32 5330 + put WorldToObject = put @Word32 5331 +--put HitT = put @Word32 5332 + put HitKind = put @Word32 5333 + put IncomingRayFlags = put @Word32 5351 + put RayGeometryIndex = put @Word32 5352 + +instance Demotable Builtin where + type Demote Builtin = Builtin +instance Known Builtin Position where + known = Position +instance Known Builtin PointSize where + known = PointSize +instance Known Builtin ClipDistance where + known = ClipDistance +instance Known Builtin CullDistance where + known = CullDistance +instance Known Builtin VertexId where + known = VertexId +instance Known Builtin InstanceId where + known = InstanceId +instance Known Builtin PrimitiveId where + known = PrimitiveId +instance Known Builtin InvocationId where + known = InvocationId +instance Known Builtin Layer where + known = Layer +instance Known Builtin ViewportIndex where + known = ViewportIndex +instance Known Builtin TessLevelOuter where + known = TessLevelOuter +instance Known Builtin TessLevelInner where + known = TessLevelInner +instance Known Builtin TessCoord where + known = TessCoord +instance Known Builtin PatchVertices where + known = PatchVertices +instance Known Builtin FragCoord where + known = FragCoord +instance Known Builtin PointCoord where + known = PointCoord +instance Known Builtin FrontFacing where + known = FrontFacing +instance Known Builtin SampleId where + known = SampleId +instance Known Builtin SamplePosition where + known = SamplePosition +instance Known Builtin SampleMask where + known = SampleMask +instance Known Builtin FragDepth where + known = FragDepth +instance Known Builtin HelperInvocation where + known = HelperInvocation +instance Known Builtin NumWorkgroups where + known = NumWorkgroups +instance Known Builtin WorkgroupSize where + known = WorkgroupSize +instance Known Builtin WorkgroupId where + known = WorkgroupId +instance Known Builtin LocalInvocationId where + known = LocalInvocationId +instance Known Builtin GlobalInvocationId where + known = GlobalInvocationId +instance Known Builtin LocalInvocationIndex where + known = LocalInvocationIndex +instance Known Builtin WorkDim where + known = WorkDim +instance Known Builtin GlobalSize where + known = GlobalSize +instance Known Builtin EnqueuedWorkgroupSize where + known = EnqueuedWorkgroupSize +instance Known Builtin GlobalOffset where + known = GlobalOffset +instance Known Builtin GlobalLinearId where + known = GlobalLinearId +instance Known Builtin SubgroupSize where + known = SubgroupSize +instance Known Builtin SubgroupMaxSize where + known = SubgroupMaxSize +instance Known Builtin NumSubgroups where + known = NumSubgroups +instance Known Builtin NumEnqueuedSubgroups where + known = NumEnqueuedSubgroups +instance Known Builtin SubgroupId where + known = SubgroupId +instance Known Builtin SubgroupLocalInvocationId where + known = SubgroupLocalInvocationId +instance Known Builtin VertexIndex where + known = VertexIndex +instance Known Builtin InstanceIndex where + known = InstanceIndex +instance Known Builtin LaunchID where + known = LaunchID +instance Known Builtin LaunchSize where + known = LaunchSize +instance Known Builtin WorldRayOrigin where + known = WorldRayOrigin +instance Known Builtin WorldRayDirection where + known = WorldRayDirection +instance Known Builtin ObjectRayOrigin where + known = ObjectRayOrigin +instance Known Builtin ObjectRayDirection where + known = ObjectRayDirection +instance Known Builtin RayTMin where + known = RayTMin +instance Known Builtin RayTMax where + known = RayTMax +instance Known Builtin InstanceCustomIndex where + known = InstanceCustomIndex +instance Known Builtin ObjectToWorld where + known = ObjectToWorld +instance Known Builtin WorldToObject where + known = WorldToObject +--instance Known Builtin HitT where +-- known = HitT +instance Known Builtin HitKind where + known = HitKind +instance Known Builtin IncomingRayFlags where + known = IncomingRayFlags +instance Known Builtin RayGeometryIndex where + known = RayGeometryIndex diff --git a/src/SPIRV/Capability.hs b/src/SPIRV/Capability.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Capability.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +{-| +Module: SPIRV.Capability + +Enumeration of SPIR-V capabilities. These are used at the value-level only. + +A capability must be declared whenever an operation is used which requires it. +See the SPIR-V specification, section 3.31 __Capability__. + +-} + +module SPIRV.Capability where + +-- base +import Data.String + ( IsString(..) ) +import Data.Word + ( Word32 ) + +-- template-haskell +import Language.Haskell.TH.Syntax + ( Lift ) + +-- fir +import Data.Binary.Class.Put + ( Put ) + +-------------------------------------------------- + +newtype Capability = Capability Word32 + deriving newtype ( Eq, Ord, Put ) + deriving stock Lift + +instance Show Capability where + show capability = "Capability " ++ showCapability capability + + +pattern Matrix :: Capability +pattern Matrix = Capability 0 + +pattern Shader :: Capability +pattern Shader = Capability 1 + +pattern Geometry :: Capability +pattern Geometry = Capability 2 + +pattern Tessellation :: Capability +pattern Tessellation = Capability 3 + +pattern Addresses :: Capability +pattern Addresses = Capability 4 + +pattern Linkage :: Capability +pattern Linkage = Capability 5 + +pattern ComputeKernel :: Capability +pattern ComputeKernel = Capability 6 + +pattern Vector16 :: Capability +pattern Vector16 = Capability 7 + +pattern Float16Buffer :: Capability +pattern Float16Buffer = Capability 8 + +pattern Float16 :: Capability +pattern Float16 = Capability 9 + +pattern Float64 :: Capability +pattern Float64 = Capability 10 + +pattern Int64 :: Capability +pattern Int64 = Capability 11 + +pattern Int64Atomics :: Capability +pattern Int64Atomics = Capability 12 + +pattern ImageBasic :: Capability +pattern ImageBasic = Capability 13 + +pattern ImageReadWrite :: Capability +pattern ImageReadWrite = Capability 14 + +pattern ImageMipmap :: Capability +pattern ImageMipmap = Capability 15 + +-- no 16 + +pattern Pipes :: Capability +pattern Pipes = Capability 17 + +pattern Groups :: Capability +pattern Groups = Capability 18 + +pattern DeviceEnqueue :: Capability +pattern DeviceEnqueue = Capability 19 + +pattern LiteralSampler :: Capability +pattern LiteralSampler = Capability 20 + +pattern AtomicStorage :: Capability +pattern AtomicStorage = Capability 21 + +pattern Int16 :: Capability +pattern Int16 = Capability 22 + +pattern TessellationPointSize :: Capability +pattern TessellationPointSize = Capability 23 + +pattern GeometryPointSize :: Capability +pattern GeometryPointSize = Capability 24 + +pattern ImageGatherExtended :: Capability +pattern ImageGatherExtended = Capability 25 + +-- no 26 + +pattern StorageImageMultisample :: Capability +pattern StorageImageMultisample = Capability 27 + +pattern UniformBufferArrayDynamicIndexing :: Capability +pattern UniformBufferArrayDynamicIndexing = Capability 28 + +pattern SampledImageArrayDynamicIndexing :: Capability +pattern SampledImageArrayDynamicIndexing = Capability 29 + +pattern StorageBufferArrayDynamicIndexing :: Capability +pattern StorageBufferArrayDynamicIndexing = Capability 30 + +pattern StorageImageArrayDynamicIndexing :: Capability +pattern StorageImageArrayDynamicIndexing = Capability 31 + +pattern ClipDistance :: Capability +pattern ClipDistance = Capability 32 + +pattern CullDistance :: Capability +pattern CullDistance = Capability 33 + +pattern ImageCubeArray :: Capability +pattern ImageCubeArray = Capability 34 + +pattern SampleRateShading :: Capability +pattern SampleRateShading = Capability 35 + +pattern ImageRect :: Capability +pattern ImageRect = Capability 36 + +pattern SampledRect :: Capability +pattern SampledRect = Capability 37 + +pattern GenericPointer :: Capability +pattern GenericPointer = Capability 38 + +pattern Int8 :: Capability +pattern Int8 = Capability 39 + +pattern InputAttachment :: Capability +pattern InputAttachment = Capability 40 + +pattern SparseResidency :: Capability +pattern SparseResidency = Capability 41 + +pattern MinLod :: Capability +pattern MinLod = Capability 42 + +pattern Sampled1D :: Capability +pattern Sampled1D = Capability 43 + +pattern Image1D :: Capability +pattern Image1D = Capability 44 + +pattern SampledCubeArray :: Capability +pattern SampledCubeArray = Capability 45 + +pattern SampledBuffer :: Capability +pattern SampledBuffer = Capability 46 + +pattern ImageBuffer :: Capability +pattern ImageBuffer = Capability 47 + +pattern ImageMSArray :: Capability +pattern ImageMSArray = Capability 48 + +pattern StorageImageExtendedFormats :: Capability +pattern StorageImageExtendedFormats = Capability 49 + +pattern ImageQuery :: Capability +pattern ImageQuery = Capability 50 + +pattern DerivativeControl :: Capability +pattern DerivativeControl = Capability 51 + +pattern InterpolationFunction :: Capability +pattern InterpolationFunction = Capability 52 + +pattern TransformFeedback :: Capability +pattern TransformFeedback = Capability 53 + +pattern GeometryStreams :: Capability +pattern GeometryStreams = Capability 54 + +pattern StorageImageReadWithoutFormat :: Capability +pattern StorageImageReadWithoutFormat = Capability 55 + +pattern StorageImageWriteWithoutFormat :: Capability +pattern StorageImageWriteWithoutFormat = Capability 56 + +pattern MultiViewport :: Capability +pattern MultiViewport = Capability 57 + +-- no 61 +pattern GroupNonUniform :: Capability +pattern GroupNonUniform = Capability 61 + +pattern GroupNonUniformVote :: Capability +pattern GroupNonUniformVote = Capability 62 + +pattern GroupNonUniformArithmetic :: Capability +pattern GroupNonUniformArithmetic = Capability 63 + +pattern GroupNonUniformBallot :: Capability +pattern GroupNonUniformBallot = Capability 64 + +pattern GroupNonUniformShuffle :: Capability +pattern GroupNonUniformShuffle = Capability 65 + +pattern GroupNonUniformShuffleRelative :: Capability +pattern GroupNonUniformShuffleRelative = Capability 66 + +pattern GroupNonUniformClustered :: Capability +pattern GroupNonUniformClustered = Capability 67 + +pattern GroupNonUniformQuad :: Capability +pattern GroupNonUniformQuad = Capability 68 + +-- extensions +pattern RayQueryKHR :: Capability +pattern RayQueryKHR = Capability 4472 + +pattern RayTraversalPrimitiveCullingKHR :: Capability +pattern RayTraversalPrimitiveCullingKHR = Capability 4478 + +pattern RayTracingKHR :: Capability +pattern RayTracingKHR = Capability 4479 + +pattern MeshShadingNV :: Capability +pattern MeshShadingNV = Capability 5266 + +pattern BitInstructions :: Capability +pattern BitInstructions = Capability 6025 + +pattern AtomicFloat32MinMaxEXT :: Capability +pattern AtomicFloat32MinMaxEXT = Capability 5612 + +pattern AtomicFloat64MinMaxEXT :: Capability +pattern AtomicFloat64MinMaxEXT = Capability 5613 + +pattern AtomicFloat16MinMaxEXT :: Capability +pattern AtomicFloat16MinMaxEXT = Capability 5616 + +pattern AtomicFloat32AddEXT :: Capability +pattern AtomicFloat32AddEXT = Capability 6033 + +pattern AtomicFloat64AddEXT :: Capability +pattern AtomicFloat64AddEXT = Capability 6034 + +pattern AtomicFloat16AddEXT :: Capability +pattern AtomicFloat16AddEXT = Capability 6095 + +showCapability :: IsString string => Capability -> string +showCapability Matrix = "Matrix" +showCapability Shader = "Shader" +showCapability Geometry = "Geometry" +showCapability Tessellation = "Tessellation" +showCapability Addresses = "Addresses" +showCapability Linkage = "Linkage" +showCapability ComputeKernel = "ComputeKernel" +showCapability Vector16 = "Vector16" +showCapability Float16Buffer = "Float16Buffer" +showCapability Float16 = "Float16" +showCapability Float64 = "Float64" +showCapability Int64 = "Int64" +showCapability Int64Atomics = "Int64Atomics" +showCapability ImageBasic = "ImageBasic" +showCapability ImageReadWrite = "ImageReadWrite" +showCapability ImageMipmap = "ImageMipmap" +showCapability Pipes = "Pipes" +showCapability Groups = "Groups" +showCapability DeviceEnqueue = "DeviceEnqueue" +showCapability LiteralSampler = "LiteralSampler" +showCapability AtomicStorage = "AtomicStorage" +showCapability Int16 = "Int16" +showCapability TessellationPointSize = "TessellationPointSize" +showCapability GeometryPointSize = "GeometryPointSize" +showCapability ImageGatherExtended = "ImageGatherExtended" +showCapability StorageImageMultisample = "StorageImageMultisample" +showCapability UniformBufferArrayDynamicIndexing = "UniformBufferArrayDynamicIndexing" +showCapability SampledImageArrayDynamicIndexing = "SampledImageArrayDynamicIndexing" +showCapability StorageBufferArrayDynamicIndexing = "StorageBufferArrayDynamicIndexing" +showCapability StorageImageArrayDynamicIndexing = "StorageImageArrayDynamicIndexing" +showCapability ClipDistance = "ClipDistance" +showCapability CullDistance = "CullDistance" +showCapability ImageCubeArray = "ImageCubeArray" +showCapability SampleRateShading = "SampleRateShading" +showCapability ImageRect = "ImageRect" +showCapability SampledRect = "SampledRect" +showCapability GenericPointer = "GenericPointer" +showCapability Int8 = "Int8" +showCapability InputAttachment = "InputAttachment" +showCapability SparseResidency = "SparseResidency" +showCapability MinLod = "MinLod" +showCapability Sampled1D = "Sampled1D" +showCapability Image1D = "Image1D" +showCapability SampledCubeArray = "SampledCubeArray" +showCapability SampledBuffer = "SampledBuffer" +showCapability ImageBuffer = "ImageBuffer" +showCapability ImageMSArray = "ImageMSArray" +showCapability StorageImageExtendedFormats = "StorageImageExtendedFormats" +showCapability ImageQuery = "ImageQuery" +showCapability DerivativeControl = "DerivativeControl" +showCapability InterpolationFunction = "InterpolationFunction" +showCapability TransformFeedback = "TransformFeedback" +showCapability GeometryStreams = "GeometryStreams" +showCapability StorageImageReadWithoutFormat = "StorageImageReadWithoutFormat" +showCapability StorageImageWriteWithoutFormat = "StorageImageWriteWithoutFormat" +showCapability MultiViewport = "MultiViewport" +showCapability GroupNonUniform = "GroupNonUniform" +showCapability GroupNonUniformVote = "GroupNonUniformVote" +showCapability GroupNonUniformArithmetic = "GroupNonUniformArithmetic" +showCapability GroupNonUniformBallot = "GroupNonUniformBallot" +showCapability GroupNonUniformShuffle = "GroupNonUniformShuffle" +showCapability GroupNonUniformShuffleRelative = "GroupNonUniformShuffleRelative" +showCapability GroupNonUniformClustered = "GroupNonUniformClustered" +showCapability GroupNonUniformQuad = "GroupNonUniformQuad" +showCapability RayQueryKHR = "RayQueryKHR" +showCapability RayTraversalPrimitiveCullingKHR = "RayTraversalPrimitiveCullingKHR" +showCapability RayTracingKHR = "RayTracingKHR" +showCapability MeshShadingNV = "MeshShadingNV" +showCapability BitInstructions = "BitInstructions" +showCapability AtomicFloat32MinMaxEXT = "AtomicFloat32MinMaxEXT" +showCapability AtomicFloat64MinMaxEXT = "AtomicFloat64MinMaxEXT" +showCapability AtomicFloat16MinMaxEXT = "AtomicFloat16MinMaxEXT" +showCapability AtomicFloat32AddEXT = "AtomicFloat32AddEXT" +showCapability AtomicFloat64AddEXT = "AtomicFloat64AddEXT" +showCapability AtomicFloat16AddEXT = "AtomicFloat16AddEXT" +showCapability (Capability i) = fromString ( show i ) diff --git a/src/SPIRV/Control.hs b/src/SPIRV/Control.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Control.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module: SPIRV.Control + +This module enumerates SPIR-V control parameters: + + * selection control parameters (SPIR-V specification §3.22 __Selection Control__), + * loop control parameters (SPIR-V specification §3.23 __Loop Control__), + * function control parameters (SPIR-V specification §3.24 __Function Control__). + +These are used both at the type-level and value-level. + +-} + +module SPIRV.Control + ( Inlineability(..) + , SideEffects(..) + , FunctionControl + , type NoFunctionControl, pattern NoFunctionControl + , SelectionControl(..), pattern NoSelectionControl + , LoopUnrolling(..) + , LoopDependency(..) + , LoopControl + , type NoLoopControl, pattern NoLoopControl + ) + where + +-- base +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( Nat, KnownNat ) + +-- binary +import qualified Data.Binary.Put as Binary + +-- fir +import Data.Binary.Class.Put + ( Put(..) ) +import Data.Type.Known + ( Demotable(Demote), Known(known), knownValue ) + +------------------------------------------------------------------------------------------------ +-- function control + +data Inlineability = Inline | DontInline + deriving stock ( Eq, Show ) +data SideEffects = OnlyReads | NoSideEffects + deriving stock ( Eq, Show ) + +type FunctionControl = ( Maybe Inlineability, Maybe SideEffects ) + +type NoFunctionControl = ( '( 'Nothing, 'Nothing ) :: FunctionControl ) + +pattern NoFunctionControl :: FunctionControl +pattern NoFunctionControl = ( Nothing, Nothing ) + +instance Put FunctionControl where + wordCount _ = 1 + put ( i, s ) = put w + where w :: Word32 + w = wi + ws + wi = case i of + Nothing -> 0 + Just Inline -> 1 + Just DontInline -> 2 + ws = case s of + Nothing -> 0 + Just OnlyReads -> 4 + Just NoSideEffects -> 8 + +instance Demotable Inlineability where + type Demote Inlineability = Inlineability +instance Known Inlineability 'Inline where + known = Inline +instance Known Inlineability 'DontInline where + known = DontInline + +instance Demotable SideEffects where + type Demote SideEffects = SideEffects +instance Known SideEffects 'OnlyReads where + known = OnlyReads +instance Known SideEffects 'NoSideEffects where + known = NoSideEffects + + +------------------------------------------------------------------------------------------------ +-- selection control + +data SelectionControl + = Flatten + | DontFlatten + deriving stock ( Eq, Show ) + +pattern NoSelectionControl :: Maybe SelectionControl +pattern NoSelectionControl = Nothing + +instance Put SelectionControl where + wordCount _ = 1 + put Flatten = put @Word32 1 + put DontFlatten = put @Word32 2 + +instance Put (Maybe SelectionControl) where + wordCount _ = 1 + put Nothing = put @Word32 0 + put (Just Flatten ) = put @Word32 1 + put (Just DontFlatten) = put @Word32 2 + +instance Demotable SelectionControl where + type Demote SelectionControl = SelectionControl +instance Known SelectionControl Flatten where + known = Flatten +instance Known SelectionControl DontFlatten where + known = DontFlatten + +------------------------------------------------------------------------------------------------ +-- loop control + +data LoopUnrolling + = Unroll + | DontUnroll + deriving stock ( Eq, Show ) + +data LoopDependency n + = DependencyInfinite + | DependencyLength n + deriving stock ( Eq, Show ) + +type LoopControl n = ( Maybe LoopUnrolling, Maybe (LoopDependency n) ) +type NoLoopControl = ( '( Nothing, Nothing ) :: LoopControl Nat ) +pattern NoLoopControl :: LoopControl Word32 +pattern NoLoopControl = ( Nothing, Nothing ) + +instance Demotable LoopUnrolling where + type Demote LoopUnrolling = LoopUnrolling +instance Known LoopUnrolling Unroll where + known = Unroll +instance Known LoopUnrolling DontUnroll where + known = DontUnroll + +instance Demotable (LoopDependency Nat) where + type Demote (LoopDependency Nat) = LoopDependency Word32 +instance Known (LoopDependency Nat) DependencyInfinite where + known = DependencyInfinite +instance KnownNat l => Known (LoopDependency Nat) (DependencyLength l) where + known = DependencyLength ( knownValue @l ) + + +instance Put (LoopControl Word32) where + wordCount (_, Just (DependencyLength _)) = 2 + wordCount _ = 1 + put ( u, d ) = put w *> mbPutDependencyLength + where w :: Word32 + w = wu + wd + wu = case u of + Nothing -> 0 + Just Unroll -> 1 + Just DontUnroll -> 2 + wd = case d of + Nothing -> 0 + Just DependencyInfinite -> 4 + Just (DependencyLength _) -> 8 + mbPutDependencyLength :: Binary.PutM () + mbPutDependencyLength = case d of + Just (DependencyLength l) -> put l + _ -> pure () diff --git a/src/SPIRV/Decoration.hs b/src/SPIRV/Decoration.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Decoration.hs @@ -0,0 +1,245 @@ + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: SPIRV.Decoration + +This module enumerates SPIR-V decorations. Used both at the type-level and term-level. + +See SPIR-V specification §3.20 __Decoration__. + +In this library, decorations are usually provided as part of a top-level definition specifying an interface +for a SPIR-V module. See "FIR.Definition". + +-} + +module SPIRV.Decoration + ( Decoration(..) + , Decorations + ) + where + +-- base +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( Nat ) + +-- containers +import Data.Set + ( Set ) + +-- fir +import Data.Binary.Class.Put + ( Put(..) ) +import Data.Type.Known + ( Demotable(Demote), Known(known), knownValue ) +import qualified SPIRV.Builtin as Builtin + +-------------------------------------------------- + +data Decoration a + = RelaxedPrecision + | SpecId a + | Block + -- | BufferBlock -- deprecated + | RowMajor + | ColMajor + | ArrayStride a + | MatrixStride a + | GLSLShared + | GLSLPacked + | CPacked + | Builtin Builtin.Builtin + -- no 12 + | NoPerspective + | Flat + | Patch + | Centroid + | Sample + | Invariant + | Restrict + | Aliased + | Volatile + | Constant + | Coherent + | NonWritable + | NonReadable + | DynamicallyUniform -- simply called 'Uniform' in the SPIR-V spec + -- no 27 + | SaturatedConversion + | Stream a + | Location a + | Component a + | Index a + | Binding a + | DescriptorSet a + | Offset a + | XfbBuffer a + | XfbStride a + -- | FuncParamAttr Attribute + -- | FPRoundingMode RoundingMode + -- | FPFastMathMode FastMathMode + -- | LinkageAttributes Word32 LinkageType + | NoContraction + | InputAttachmentIndex a + | Alignment a + deriving stock ( Show, Eq, Ord ) + +type Decorations = Set (Decoration Word32) + +instance Put (Decoration Word32) where + put RelaxedPrecision = put @Word32 0 + put (SpecId i) = put @Word32 1 *> put i + put Block = put @Word32 2 + --put BufferBlock = put @Word32 3 + put RowMajor = put @Word32 4 + put ColMajor = put @Word32 5 + put (ArrayStride i) = put @Word32 6 *> put i + put (MatrixStride i) = put @Word32 7 *> put i + put GLSLShared = put @Word32 8 + put GLSLPacked = put @Word32 9 + put CPacked = put @Word32 10 + put (Builtin builtin) = put @Word32 11 *> put builtin + -- + put NoPerspective = put @Word32 13 + put Flat = put @Word32 14 + put Patch = put @Word32 15 + put Centroid = put @Word32 16 + put Sample = put @Word32 17 + put Invariant = put @Word32 18 + put Restrict = put @Word32 19 + put Aliased = put @Word32 20 + put Volatile = put @Word32 21 + put Constant = put @Word32 22 + put Coherent = put @Word32 23 + put NonWritable = put @Word32 24 + put NonReadable = put @Word32 25 + put DynamicallyUniform = put @Word32 26 + -- + put SaturatedConversion = put @Word32 28 + put (Stream i) = put @Word32 29 *> put i + put (Location i) = put @Word32 30 *> put i + put (Component i) = put @Word32 31 *> put i + put (Index i) = put @Word32 32 *> put i + put (Binding i) = put @Word32 33 *> put i + put (DescriptorSet i) = put @Word32 34 *> put i + put (Offset i) = put @Word32 35 *> put i + put (XfbBuffer i) = put @Word32 36 *> put i + put (XfbStride i) = put @Word32 37 *> put i + -- + -- + -- + -- + put NoContraction = put @Word32 42 + put (InputAttachmentIndex i) = put @Word32 43 *> put i + put (Alignment i) = put @Word32 44 *> put i + + wordCount (SpecId _) = 2 + wordCount (ArrayStride _) = 2 + wordCount (MatrixStride _) = 2 + wordCount (Builtin _) = 2 + wordCount (Stream _) = 2 + wordCount (Location _) = 2 + wordCount (Component _) = 2 + wordCount (Index _) = 2 + wordCount (Binding _) = 2 + wordCount (DescriptorSet _) = 2 + wordCount (Offset _) = 2 + wordCount (XfbBuffer _) = 2 + wordCount (XfbStride _) = 2 + wordCount (InputAttachmentIndex _) = 2 + wordCount (Alignment _) = 2 + wordCount _ = 1 + +instance Demotable (Decoration Nat) where + type Demote (Decoration Nat) = Decoration Word32 + +instance Known (Decoration Nat) RelaxedPrecision where + known = RelaxedPrecision +instance Known Nat i => Known (Decoration Nat) (SpecId i) where + known = SpecId ( knownValue @i ) +instance Known (Decoration Nat) Block where + known = Block +--instance Known (Decoration Nat) BufferBlock where +-- known = BufferBlock +instance Known (Decoration Nat) RowMajor where + known = RowMajor +instance Known (Decoration Nat) ColMajor where + known = ColMajor +instance Known Nat i => Known (Decoration Nat) (ArrayStride i) where + known = ArrayStride ( knownValue @i ) +instance Known Nat i => Known (Decoration Nat) (MatrixStride i) where + known = MatrixStride ( knownValue @i ) +instance Known (Decoration Nat) GLSLShared where + known = GLSLShared +instance Known (Decoration Nat) GLSLPacked where + known = GLSLPacked +instance Known (Decoration Nat) CPacked where + known = CPacked +instance Known Builtin.Builtin builtin => Known (Decoration Nat) (Builtin builtin) where + known = Builtin ( knownValue @builtin ) +instance Known (Decoration Nat) NoPerspective where + known = NoPerspective +instance Known (Decoration Nat) Flat where + known = Flat +instance Known (Decoration Nat) Patch where + known = Patch +instance Known (Decoration Nat) Centroid where + known = Centroid +instance Known (Decoration Nat) Sample where + known = Sample +instance Known (Decoration Nat) Invariant where + known = Invariant +instance Known (Decoration Nat) Restrict where + known = Restrict +instance Known (Decoration Nat) Aliased where + known = Aliased +instance Known (Decoration Nat) Volatile where + known = Volatile +instance Known (Decoration Nat) Constant where + known = Constant +instance Known (Decoration Nat) Coherent where + known = Coherent +instance Known (Decoration Nat) NonWritable where + known = NonWritable +instance Known (Decoration Nat) NonReadable where + known = NonReadable +instance Known (Decoration Nat) DynamicallyUniform where + known = DynamicallyUniform +instance Known (Decoration Nat) SaturatedConversion where + known = SaturatedConversion +instance Known Nat i => Known (Decoration Nat) (Stream i) where + known = Stream ( knownValue @i ) +instance Known Nat i => Known (Decoration Nat) (Location i) where + known = Location ( knownValue @i ) +instance Known Nat i => Known (Decoration Nat) (Component i) where + known = Component ( knownValue @i ) +instance Known Nat i => Known (Decoration Nat) (Index i) where + known = Index ( knownValue @i ) +instance Known Nat i => Known (Decoration Nat) (Binding i) where + known = Binding ( knownValue @i ) +instance Known Nat i => Known (Decoration Nat) (DescriptorSet i) where + known = DescriptorSet ( knownValue @i ) +instance Known Nat i => Known (Decoration Nat) (Offset i) where + known = Offset ( knownValue @i ) +instance Known Nat i => Known (Decoration Nat) (XfbBuffer i) where + known = XfbBuffer ( knownValue @i ) +instance Known Nat i => Known (Decoration Nat) (XfbStride i) where + known = XfbStride ( knownValue @i ) +instance Known (Decoration Nat) NoContraction where + known = NoContraction +instance Known Nat i => Known (Decoration Nat) (InputAttachmentIndex i) where + known = InputAttachmentIndex ( knownValue @i ) +instance Known Nat i => Known (Decoration Nat) (Alignment i) where + known = Alignment ( knownValue @i ) diff --git a/src/SPIRV/ExecutionMode.hs b/src/SPIRV/ExecutionMode.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/ExecutionMode.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-| +Module: SPIRV.ExecutionMode + +This module enumerates SPIR-V execution modes. These are used both at the type-level and value-level. + +These annotate execution models / shader stages (see "SPIRV.Stage") with further information, +such as the geometry type to use in a tessellation shader (points, triangles, quads, isolines), +or the workgroup size in a compute shader. + +See the SPIR-V specification §3.6 __Execution Modes__. + +-} + +module SPIRV.ExecutionMode where + +-- base +import Data.Word + ( Word32 ) +import GHC.TypeNats + ( Nat ) + +-- containers +import Data.Set + ( Set ) + +-- fir +import Data.Binary.Class.Put + ( Put(..) ) +import Data.Type.Known + ( Demotable(Demote), Known(known), knownValue ) + +-------------------------------------------------- +-- execution modes + +data ExecutionMode a + = Invocations a + | SpacingEqual + | SpacingFractionalEven + | SpacingFractionalOdd + | VertexOrderCw + | VertexOrderCcw + | PixelCenterInteger + | OriginUpperLeft + | OriginLowerLeft + | EarlyFragmentTests + | PointMode + | Xfb + | DepthReplacing + | DepthGreater + | DepthLess + | DepthUnchanged + | LocalSize a a a + | LocalSizeHint a a a + | InputPoints + | InputLines + | InputLinesAdjacency + | Triangles + | InputTrianglesAdjacency + | Quads + | Isolines + | OutputVertices a + | OutputPoints + | OutputLineStrip + | OutputTriangleStrip + | VecTypeHint a + | ContractionOff + -- custom information that does not align with the SPIR-V spec + | MaxPatchVertices a + deriving stock ( Show, Eq, Ord ) + +type InputVertices i = OutputVertices i + -- synonym for providing number of input vertices for a tessellation evaluation shader + +type ExecutionModes = Set (ExecutionMode Word32) + +instance Put (ExecutionMode Word32) where + put (Invocations i) = put @Word32 0 *> put i + put SpacingEqual = put @Word32 1 + put SpacingFractionalEven = put @Word32 2 + put SpacingFractionalOdd = put @Word32 3 + put VertexOrderCw = put @Word32 4 + put VertexOrderCcw = put @Word32 5 + put PixelCenterInteger = put @Word32 6 + put OriginUpperLeft = put @Word32 7 + put OriginLowerLeft = put @Word32 8 + put EarlyFragmentTests = put @Word32 9 + put PointMode = put @Word32 10 + put Xfb = put @Word32 11 + put DepthReplacing = put @Word32 12 + put DepthGreater = put @Word32 14 + put DepthLess = put @Word32 15 + put DepthUnchanged = put @Word32 16 + put (LocalSize x y z) = put @Word32 17 *> put x *> put y *> put z + put (LocalSizeHint x y z) = put @Word32 18 *> put x *> put y *> put z + put InputPoints = put @Word32 19 + put InputLines = put @Word32 20 + put InputLinesAdjacency = put @Word32 21 + put Triangles = put @Word32 22 + put InputTrianglesAdjacency = put @Word32 23 + put Quads = put @Word32 24 + put Isolines = put @Word32 25 + put (OutputVertices i) = put @Word32 26 *> put i + put OutputPoints = put @Word32 27 + put OutputLineStrip = put @Word32 28 + put OutputTriangleStrip = put @Word32 29 + put (VecTypeHint i) = put @Word32 30 *> put i + put ContractionOff = put @Word32 31 + put (MaxPatchVertices _) + = error "Cannot put custom 'MaxPatchVertices' execution mode." + + wordCount Invocations {} = 2 + wordCount LocalSize {} = 4 + wordCount LocalSizeHint {} = 4 + wordCount OutputVertices {} = 2 + wordCount VecTypeHint {} = 2 + wordCount MaxPatchVertices {} = error "Cannot compute size of custom 'MaxPatchVertices' execution mode." + wordCount _ = 1 + +instance Demotable (ExecutionMode Nat) where + type Demote (ExecutionMode Nat) = ExecutionMode Word32 + +instance Known Nat i => Known (ExecutionMode Nat) (Invocations i) where + known = Invocations ( knownValue @i ) +instance Known (ExecutionMode Nat) SpacingEqual where + known = SpacingEqual +instance Known (ExecutionMode Nat) SpacingFractionalEven where + known = SpacingFractionalEven +instance Known (ExecutionMode Nat) SpacingFractionalOdd where + known = SpacingFractionalOdd +instance Known (ExecutionMode Nat) VertexOrderCw where + known = VertexOrderCw +instance Known (ExecutionMode Nat) VertexOrderCcw where + known = VertexOrderCcw +instance Known (ExecutionMode Nat) PixelCenterInteger where + known = PixelCenterInteger +instance Known (ExecutionMode Nat) OriginUpperLeft where + known = OriginUpperLeft +instance Known (ExecutionMode Nat) OriginLowerLeft where + known = OriginLowerLeft +instance Known (ExecutionMode Nat) EarlyFragmentTests where + known = EarlyFragmentTests +instance Known (ExecutionMode Nat) PointMode where + known = PointMode +instance Known (ExecutionMode Nat) Xfb where + known = Xfb +instance Known (ExecutionMode Nat) DepthReplacing where + known = DepthReplacing +instance Known (ExecutionMode Nat) DepthGreater where + known = DepthGreater +instance Known (ExecutionMode Nat) DepthLess where + known = DepthLess +instance Known (ExecutionMode Nat) DepthUnchanged where + known = DepthUnchanged +instance (Known Nat x, Known Nat y, Known Nat z) + => Known (ExecutionMode Nat) (LocalSize x y z) where + known = LocalSize + ( knownValue @x ) + ( knownValue @y ) + ( knownValue @z ) +instance (Known Nat x, Known Nat y, Known Nat z) + => Known (ExecutionMode Nat) (LocalSizeHint x y z) where + known = LocalSizeHint + ( knownValue @x ) + ( knownValue @y ) + ( knownValue @z ) +instance Known (ExecutionMode Nat) InputPoints where + known = InputPoints +instance Known (ExecutionMode Nat) InputLines where + known = InputLines +instance Known (ExecutionMode Nat) InputLinesAdjacency where + known = InputLinesAdjacency +instance Known (ExecutionMode Nat) Triangles where + known = Triangles +instance Known (ExecutionMode Nat) InputTrianglesAdjacency where + known = InputTrianglesAdjacency +instance Known (ExecutionMode Nat) Quads where + known = Quads +instance Known (ExecutionMode Nat) Isolines where + known = Isolines +instance Known Nat i => Known (ExecutionMode Nat) (OutputVertices i) where + known = OutputVertices ( knownValue @i ) +instance Known (ExecutionMode Nat) OutputPoints where + known = OutputPoints +instance Known (ExecutionMode Nat) OutputLineStrip where + known = OutputLineStrip +instance Known (ExecutionMode Nat) OutputTriangleStrip where + known = OutputTriangleStrip +instance Known Nat i => Known (ExecutionMode Nat) (VecTypeHint i) where + known = VecTypeHint ( knownValue @i ) +instance Known (ExecutionMode Nat) ContractionOff where + known = ContractionOff +instance Known Nat i => Known (ExecutionMode Nat) (MaxPatchVertices i) where + known = MaxPatchVertices ( knownValue @i ) diff --git a/src/SPIRV/Extension.hs b/src/SPIRV/Extension.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Extension.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +{-| +Module: SPIRV.Extension + +This module enumerates SPIR-V extensions as well as extended instruction sets. +These are used only at the value level. + +See SPIR-V specification §2.10 __Extended Instruction Sets__, +as well as the SPIR-V registry for a complete list of SPIR-V extensions. + +-} + +module SPIRV.Extension where + +-- template-haskell +import Language.Haskell.TH.Syntax + ( Lift ) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- fir +import Instances.TH.Lift + ( ) -- Lift instance for ShortText +import Data.Binary.Class.Put + ( Put ) + +-------------------------------------------------- +-- extended instruction sets + +data ExtInst + = OpenCL + | GLSL + | DebugPrintf + deriving stock ( Show, Eq, Ord, Enum, Bounded ) + +extInstName :: ExtInst -> ShortText +extInstName OpenCL = "OpenCL.std" +extInstName GLSL = "GLSL.std.450" +extInstName DebugPrintf = "NonSemantic.DebugPrintf" + +-------------------------------------------------- +-- extensions + +newtype Extension = Extension ShortText + deriving newtype ( Eq, Ord, Put ) + deriving stock ( Show, Lift ) + +pattern SPV_AMD_shader_explicit_vertex_parameter :: Extension +pattern SPV_AMD_shader_explicit_vertex_parameter = Extension "SPV_AMD_shader_explicit_vertex_parameter" +pattern SPV_AMD_shader_trinary_minmax :: Extension +pattern SPV_AMD_shader_trinary_minmax = Extension "SPV_AMD_shader_trinary_minmax" +pattern SPV_AMD_gcn_shader :: Extension +pattern SPV_AMD_gcn_shader = Extension "SPV_AMD_gcn_shader" +pattern SPV_KHR_shader_ballot :: Extension +pattern SPV_KHR_shader_ballot = Extension "SPV_KHR_shader_ballot" +pattern SPV_AMD_shader_ballot :: Extension +pattern SPV_AMD_shader_ballot = Extension "SPV_AMD_shader_ballot" +pattern SPV_AMD_gpu_shader_half_float :: Extension +pattern SPV_AMD_gpu_shader_half_float = Extension "SPV_AMD_gpu_shader_half_float" +pattern SPV_KHR_shader_draw_parameters :: Extension +pattern SPV_KHR_shader_draw_parameters = Extension "SPV_KHR_shader_draw_parameters" +pattern SPV_KHR_subgroup_vote :: Extension +pattern SPV_KHR_subgroup_vote = Extension "SPV_KHR_subgroup_vote" +pattern SPV_KHR_16bit_storage :: Extension +pattern SPV_KHR_16bit_storage = Extension "SPV_KHR_16bit_storage" +pattern SPV_KHR_device_group :: Extension +pattern SPV_KHR_device_group = Extension "SPV_KHR_device_group" +pattern SPV_KHR_multiview :: Extension +pattern SPV_KHR_multiview = Extension "SPV_KHR_multiview" +pattern SPV_NVX_multiview_per_view_attributes :: Extension +pattern SPV_NVX_multiview_per_view_attributes = Extension "SPV_NVX_multiview_per_view_attributes" +pattern SPV_NV_viewport_array2 :: Extension +pattern SPV_NV_viewport_array2 = Extension "SPV_NV_viewport_array2" +pattern SPV_NV_stereo_view_rendering :: Extension +pattern SPV_NV_stereo_view_rendering = Extension "SPV_NV_stereo_view_rendering" +pattern SPV_NV_sample_mask_override_coverage :: Extension +pattern SPV_NV_sample_mask_override_coverage = Extension "SPV_NV_sample_mask_override_coverage" +pattern SPV_NV_geometry_shader_passthrough :: Extension +pattern SPV_NV_geometry_shader_passthrough = Extension "SPV_NV_geometry_shader_passthrough" +pattern SPV_AMD_texture_gather_bias_lod :: Extension +pattern SPV_AMD_texture_gather_bias_lod = Extension "SPV_AMD_texture_gather_bias_lod" +pattern SPV_KHR_storage_buffer_storage_class :: Extension +pattern SPV_KHR_storage_buffer_storage_class = Extension "SPV_KHR_storage_buffer_storage_class" +pattern SPV_KHR_variable_pointers :: Extension +pattern SPV_KHR_variable_pointers = Extension "SPV_KHR_variable_pointers" +pattern SPV_AMD_gpu_shader_int16 :: Extension +pattern SPV_AMD_gpu_shader_int16 = Extension "SPV_AMD_gpu_shader_int16" +pattern SPV_KHR_post_depth_coverage :: Extension +pattern SPV_KHR_post_depth_coverage = Extension "SPV_KHR_post_depth_coverage" +pattern SPV_KHR_shader_atomic_counter_ops :: Extension +pattern SPV_KHR_shader_atomic_counter_ops = Extension "SPV_KHR_shader_atomic_counter_ops" +pattern SPV_EXT_shader_stencil_export :: Extension +pattern SPV_EXT_shader_stencil_export = Extension "SPV_EXT_shader_stencil_export" +pattern SPV_EXT_shader_viewport_index_layer :: Extension +pattern SPV_EXT_shader_viewport_index_layer = Extension "SPV_EXT_shader_viewport_index_layer" +pattern SPV_AMD_shader_image_load_store_lod :: Extension +pattern SPV_AMD_shader_image_load_store_lod = Extension "SPV_AMD_shader_image_load_store_lod" +pattern SPV_AMD_shader_fragment_mask :: Extension +pattern SPV_AMD_shader_fragment_mask = Extension "SPV_AMD_shader_fragment_mask" +pattern SPV_EXT_fragment_fully_covered :: Extension +pattern SPV_EXT_fragment_fully_covered = Extension "SPV_EXT_fragment_fully_covered" +pattern SPV_AMD_gpu_shader_half_float_fetch :: Extension +pattern SPV_AMD_gpu_shader_half_float_fetch = Extension "SPV_AMD_gpu_shader_half_float_fetch" +pattern SPV_GOOGLE_decorate_string :: Extension +pattern SPV_GOOGLE_decorate_string = Extension "SPV_GOOGLE_decorate_string" +pattern SPV_GOOGLE_hlsl_functionality1 :: Extension +pattern SPV_GOOGLE_hlsl_functionality1 = Extension "SPV_GOOGLE_hlsl_functionality1" +pattern SPV_NV_shader_subgroup_partitioned :: Extension +pattern SPV_NV_shader_subgroup_partitioned = Extension "SPV_NV_shader_subgroup_partitioned" +pattern SPV_EXT_descriptor_indexing :: Extension +pattern SPV_EXT_descriptor_indexing = Extension "SPV_EXT_descriptor_indexing" +pattern SPV_KHR_8bit_storage :: Extension +pattern SPV_KHR_8bit_storage = Extension "SPV_KHR_8bit_storage" +pattern SPV_KHR_vulkan_memory_model :: Extension +pattern SPV_KHR_vulkan_memory_model = Extension "SPV_KHR_vulkan_memory_model" +pattern SPV_NV_ray_tracing :: Extension +pattern SPV_NV_ray_tracing = Extension "SPV_NV_ray_tracing" +pattern SPV_NV_compute_shader_derivatives :: Extension +pattern SPV_NV_compute_shader_derivatives = Extension "SPV_NV_compute_shader_derivatives" +pattern SPV_NV_fragment_shader_barycentric :: Extension +pattern SPV_NV_fragment_shader_barycentric = Extension "SPV_NV_fragment_shader_barycentric" +pattern SPV_NV_mesh_shader :: Extension +pattern SPV_NV_mesh_shader = Extension "SPV_NV_mesh_shader" +pattern SPV_NV_shader_image_footprint :: Extension +pattern SPV_NV_shader_image_footprint = Extension "SPV_NV_shader_image_footprint" +pattern SPV_NV_shading_rate :: Extension +pattern SPV_NV_shading_rate = Extension "SPV_NV_shading_rate" +pattern SPV_INTEL_subgroups :: Extension +pattern SPV_INTEL_subgroups = Extension "SPV_INTEL_subgroups" +pattern SPV_INTEL_media_block_io :: Extension +pattern SPV_INTEL_media_block_io = Extension "SPV_INTEL_media_block_io" +pattern SPV_INTEL_device_side_avc_motion_estimation :: Extension +pattern SPV_INTEL_device_side_avc_motion_estimation = Extension "SPV_INTEL_device_side_avc_motion_estimation" +pattern SPV_EXT_fragment_invocation_density :: Extension +pattern SPV_EXT_fragment_invocation_density = Extension "SPV_EXT_fragment_invocation_density" +pattern SPV_KHR_no_integer_wrap_decoration :: Extension +pattern SPV_KHR_no_integer_wrap_decoration = Extension "SPV_KHR_no_integer_wrap_decoration" +pattern SPV_KHR_float_controls :: Extension +pattern SPV_KHR_float_controls = Extension "SPV_KHR_float_controls" +pattern SPV_EXT_physical_storage_buffer :: Extension +pattern SPV_EXT_physical_storage_buffer = Extension "SPV_EXT_physical_storage_buffer" +pattern SPV_INTEL_fpga_memory_attributes :: Extension +pattern SPV_INTEL_fpga_memory_attributes = Extension "SPV_INTEL_fpga_memory_attributes" +pattern SPV_NV_cooperative_matrix :: Extension +pattern SPV_NV_cooperative_matrix = Extension "SPV_NV_cooperative_matrix" +pattern SPV_INTEL_shader_integer_functions2 :: Extension +pattern SPV_INTEL_shader_integer_functions2 = Extension "SPV_INTEL_shader_integer_functions2" +pattern SPV_INTEL_fpga_loop_controls :: Extension +pattern SPV_INTEL_fpga_loop_controls = Extension "SPV_INTEL_fpga_loop_controls" +pattern SPV_EXT_fragment_shader_interlock :: Extension +pattern SPV_EXT_fragment_shader_interlock = Extension "SPV_EXT_fragment_shader_interlock" +pattern SPV_NV_shader_sm_builtins :: Extension +pattern SPV_NV_shader_sm_builtins = Extension "SPV_NV_shader_sm_builtins" +pattern SPV_KHR_shader_clock :: Extension +pattern SPV_KHR_shader_clock = Extension "SPV_KHR_shader_clock" +pattern SPV_INTEL_unstructured_loop_controls :: Extension +pattern SPV_INTEL_unstructured_loop_controls = Extension "SPV_INTEL_unstructured_loop_controls" +pattern SPV_EXT_demote_to_helper_invocation :: Extension +pattern SPV_EXT_demote_to_helper_invocation = Extension "SPV_EXT_demote_to_helper_invocation" +pattern SPV_INTEL_fpga_reg :: Extension +pattern SPV_INTEL_fpga_reg = Extension "SPV_INTEL_fpga_reg" +pattern SPV_INTEL_blocking_pipes :: Extension +pattern SPV_INTEL_blocking_pipes = Extension "SPV_INTEL_blocking_pipes" +pattern SPV_KHR_physical_storage_buffer :: Extension +pattern SPV_KHR_physical_storage_buffer = Extension "SPV_KHR_physical_storage_buffer" +pattern SPV_KHR_non_semantic_info :: Extension +pattern SPV_KHR_non_semantic_info = Extension "SPV_KHR_non_semantic_info" +pattern SPV_KHR_ray_tracing :: Extension +pattern SPV_KHR_ray_tracing = Extension "SPV_KHR_ray_tracing" +pattern SPV_KHR_ray_query :: Extension +pattern SPV_KHR_ray_query = Extension "SPV_KHR_ray_query" +pattern SPV_KHR_bit_instructions :: Extension +pattern SPV_KHR_bit_instructions = Extension "SPV_KHR_bit_instructions" +pattern SPV_EXT_shader_atomic_float_add :: Extension +pattern SPV_EXT_shader_atomic_float_add = Extension "SPV_EXT_shader_atomic_float_add" +pattern SPV_EXT_shader_atomic_float16_add :: Extension +pattern SPV_EXT_shader_atomic_float16_add = Extension "SPV_EXT_shader_atomic_float16_add" +pattern SPV_EXT_shader_atomic_float_min_max :: Extension +pattern SPV_EXT_shader_atomic_float_min_max = Extension "SPV_EXT_shader_atomic_float_min_max" diff --git a/src/SPIRV/Groups.hs b/src/SPIRV/Groups.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Groups.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| +Module: SPIRV.Groups + +This module defines @SPIR-V@ group operations. +-} + +module SPIRV.Groups + ( GroupOperation(..) + , groupOperationToWord32 + ) where + +-- base +import Data.Word + ( Word32 ) + +-- fir +import Data.Binary.Class.Put + ( Put(..), PutWord32Enum(..) ) +import Data.Type.Known + ( Demotable(Demote), Known(known) ) + +------------------------------------------------------------------------------- + +data GroupOperation + = Reduce + | InclusiveScan + | ExclusiveScan + | ClusteredReduce + deriving stock ( Show, Eq, Ord, Enum ) + deriving Put via ( PutWord32Enum GroupOperation ) + +groupOperationToWord32 :: GroupOperation -> Word32 +groupOperationToWord32 = fromIntegral . fromEnum + +instance Demotable GroupOperation where + type Demote GroupOperation = GroupOperation + +instance Known GroupOperation 'Reduce where + known = Reduce +instance Known GroupOperation 'InclusiveScan where + known = InclusiveScan +instance Known GroupOperation 'ExclusiveScan where + known = ExclusiveScan +instance Known GroupOperation 'ClusteredReduce where + known = ClusteredReduce diff --git a/src/SPIRV/Image.hs b/src/SPIRV/Image.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Image.hs @@ -0,0 +1,437 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: SPIRV.Image + +SPIR-V image properties, image formats, and image operand names. + +See "FIR.Prim.Image" for their use within this library. + +-} + +module SPIRV.Image where + +-- base +import Prelude hiding + ( Integral, Floating ) +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( TypeError, ErrorMessage(..) ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Binary.Class.Put + ( Put(..), PutWord32Enum(..) ) +import Data.Type.Known + ( Demotable(Demote), Known(known), knownValue ) +import Data.Type.List + ( Length ) +import SPIRV.ScalarTy + ( ScalarTy, Signedness(..) ) + +-------------------------------------------------- + +data Image + = Image + { texelComponent :: ScalarTy -- called the 'Sampled type' in SPIR-V + , dimensionality :: Dimensionality + , hasDepth :: Maybe HasDepth + , arrayness :: Arrayness + , multiSampling :: MultiSampling + , imageUsage :: Maybe ImageUsage + , imageFormat :: Maybe (ImageFormat Word32) + } + deriving stock ( Eq, Show, Ord ) + +data Dimensionality + = OneD + | TwoD + | ThreeD + | Cube + | Rect + | Buffer + | SubpassData + deriving stock ( Eq, Show, Ord, Enum, Bounded ) + deriving Put via ( PutWord32Enum Dimensionality ) + +instance Demotable Dimensionality where + type Demote Dimensionality = Dimensionality +instance Known Dimensionality 'OneD where + known = OneD +instance Known Dimensionality 'TwoD where + known = TwoD +instance Known Dimensionality 'ThreeD where + known = ThreeD +instance Known Dimensionality 'Cube where + known = Cube +instance Known Dimensionality 'Rect where + known = Rect +instance Known Dimensionality 'Buffer where + known = Buffer +instance Known Dimensionality 'SubpassData where + known = SubpassData + +data HasDepth + = NotDepthImage + | DepthImage + deriving stock ( Eq, Show, Ord, Enum, Bounded ) + deriving Put via (PutWord32Enum HasDepth) + +instance Demotable HasDepth where + type Demote HasDepth = HasDepth +instance Known HasDepth NotDepthImage where + known = NotDepthImage +instance Known HasDepth DepthImage where + known = DepthImage + +instance Put (Maybe HasDepth) where + put (Just d) = put d + put Nothing = put @Word32 2 + wordCount _ = 1 + +data Arrayness + = NonArrayed + | Arrayed + deriving stock ( Eq, Show, Ord, Enum, Bounded ) + deriving Put via (PutWord32Enum Arrayness) + +instance Demotable Arrayness where + type Demote Arrayness = Arrayness +instance Known Arrayness 'NonArrayed where + known = NonArrayed +instance Known Arrayness 'Arrayed where + known = Arrayed + +data MultiSampling + = SingleSampled + | MultiSampled + deriving stock ( Eq, Show, Ord, Enum, Bounded ) + deriving Put via (PutWord32Enum MultiSampling) + +instance Demotable MultiSampling where + type Demote MultiSampling = MultiSampling +instance Known MultiSampling 'SingleSampled where + known = SingleSampled +instance Known MultiSampling 'MultiSampled where + known = MultiSampled + +data ImageUsage + = Sampled + | Storage + deriving stock ( Eq, Show, Ord, Enum, Bounded ) + +instance Put (Maybe ImageUsage) where + put Nothing = put @Word32 0 + put (Just Sampled) = put @Word32 1 + put (Just Storage) = put @Word32 2 + wordCount _ = 1 + +instance Demotable ImageUsage where + type Demote ImageUsage = ImageUsage +instance Known ImageUsage 'Sampled where + known = Sampled +instance Known ImageUsage 'Storage where + known = Storage + +data Normalisation + = Unnormalised + | Normalised + deriving stock ( Eq, Show, Ord, Enum, Bounded ) + deriving Put via (PutWord32Enum Normalisation) + +instance Demotable Normalisation where + type Demote Normalisation = Normalisation +instance Known Normalisation Unnormalised where + known = Unnormalised +instance Known Normalisation Normalised where + known = Normalised + +data Component + = Integer Normalisation Signedness + | Floating + deriving stock ( Eq, Show, Ord ) + +instance Demotable Component where + type Demote Component = Component +instance ( Known Normalisation norm + , Known Signedness sign + ) + => Known Component ('Integer norm sign) + where + known = Integer (knownValue @norm) (knownValue @sign) +instance Known Component 'Floating where + known = Floating + +pattern SNorm :: Component +pattern SNorm = Integer Normalised Signed +type SNorm = ( 'Integer 'Normalised 'Signed :: Component ) + +pattern UNorm :: Component +pattern UNorm = Integer Normalised Unsigned +type UNorm = ( 'Integer 'Normalised 'Unsigned :: Component ) + +pattern F :: Component +pattern F = Floating +type F = ( 'Floating :: Component ) + +pattern I :: Component +pattern I = Integer Unnormalised Signed +type I = ( 'Integer 'Unnormalised 'Signed :: Component ) + +pattern UI :: Component +pattern UI = Integer Unnormalised Unsigned +type UI = ( 'Integer 'Unnormalised 'Unsigned :: Component ) + +data ImageFormat a + = ImageFormat Component [a] + deriving stock ( Eq, Show, Ord ) + +type family ImageFormatDimension ( fmt :: ImageFormat Nat ) :: Nat where + ImageFormatDimension ( 'ImageFormat _ comps ) = Length comps + +pattern RGBA32 :: Component -> ImageFormat Word32 +pattern RGBA32 component = ImageFormat component [32,32,32,32] +type family RGBA32 (component :: Component) :: ImageFormat Nat where + RGBA32 SNorm = TypeError ( Text "RGBA32 format cannot use normalised integers." ) + RGBA32 UNorm = TypeError ( Text "RGBA32 format cannot use normalised integers." ) + RGBA32 comp = 'ImageFormat comp '[32,32,32,32] + +pattern RGBA16 :: Component -> ImageFormat Word32 +pattern RGBA16 component = ImageFormat component [16,16,16,16] +type RGBA16 (component :: Component) = ( 'ImageFormat component '[16,16,16,16] :: ImageFormat Nat ) + +pattern RGBA8 :: Component -> ImageFormat Word32 +pattern RGBA8 component = ImageFormat component [8,8,8,8] +type family RGBA8 (component :: Component) :: ImageFormat Nat where + RGBA8 F = TypeError ( Text "RGBA8 format cannot use floating-point numbers." ) + RGBA8 comp = 'ImageFormat comp '[8,8,8,8] + +pattern RG32 :: Component -> ImageFormat Word32 +pattern RG32 component = ImageFormat component [32,32] +type family RG32 (component :: Component) :: ImageFormat Nat where + RG32 SNorm = TypeError ( Text "RG32 format cannot use normalised integers." ) + RG32 UNorm = TypeError ( Text "RG32 format cannot use normalised integers." ) + RG32 comp = 'ImageFormat comp '[32,32] + +pattern RG16 :: Component -> ImageFormat Word32 +pattern RG16 component = ImageFormat component [16,16] +type RG16 (component :: Component) = ( 'ImageFormat component '[16,16] :: ImageFormat Nat ) + +pattern RG8 :: Component -> ImageFormat Word32 +pattern RG8 component = ImageFormat component [8,8] +type family RG8 (component :: Component) :: ImageFormat Nat where + RG8 F = TypeError ( Text "RG8 format cannot use floating-point numbers." ) + RG8 comp = 'ImageFormat comp '[8,8] + +pattern R32 :: Component -> ImageFormat Word32 +pattern R32 component = ImageFormat component [32] +type family R32 (component :: Component) :: ImageFormat Nat where + R32 SNorm = TypeError ( Text "R32 format cannot use normalised integers." ) + R32 UNorm = TypeError ( Text "R32 format cannot use normalised integers." ) + R32 comp = 'ImageFormat comp '[32] + +pattern R16 :: Component -> ImageFormat Word32 +pattern R16 component = ImageFormat component [16] +type R16 (component :: Component) = ( 'ImageFormat component '[16] :: ImageFormat Nat ) + +pattern R8 :: Component -> ImageFormat Word32 +pattern R8 component = ImageFormat component [8] +type family R8 (component :: Component) :: ImageFormat Nat where + R8 F = TypeError ( Text "R8 format cannot use floating-point numbers." ) + R8 comp = 'ImageFormat comp '[8] + +pattern R11G11B10 :: Component -> ImageFormat Word32 +pattern R11G11B10 component = ImageFormat component [11,11,10] +type family R11G11B10 (component :: Component) :: ImageFormat Nat where + R11G11B10 F = 'ImageFormat F '[11,11,10] + R11G11B10 comp = TypeError ( Text "R11G11B10 format must use floating-point numbers." ) + +pattern RGB10A2 :: Component -> ImageFormat Word32 +pattern RGB10A2 component = ImageFormat component [10,10,10,2] +type family RGB10A2 (component :: Component) :: ImageFormat Nat where + RGB10A2 UI = 'ImageFormat UI '[10,10,10,2] + RGB10A2 UNorm = 'ImageFormat UNorm '[10,10,10,2] + RGB10A2 comp = TypeError ( Text "RGB10A2 format must use unsigned integers." ) + +instance Demotable (ImageFormat Nat) where + type Demote (ImageFormat Nat) = ImageFormat Word32 +instance ( Known Component comp + , Known [Nat] sizes + ) + => Known (ImageFormat Nat) ('ImageFormat comp sizes) + where + known = ImageFormat (knownValue @comp) (knownValue @sizes) + + +type family RequiredFormatUsage ( fmt :: ImageFormat Nat ) :: Maybe ImageUsage where + RequiredFormatUsage ('ImageFormat _ '[8,8,8,8]) = Nothing + RequiredFormatUsage ('ImageFormat ('Integer Normalised _) '[_,_,_,_]) = Just Storage + RequiredFormatUsage ('ImageFormat _ '[i,_,_,i]) = Nothing + RequiredFormatUsage ('ImageFormat _ '[32] ) = Nothing + RequiredFormatUsage ('ImageFormat _ '[_ ] ) = Just Storage + RequiredFormatUsage _ = Just Storage + +requiredFormatUsage :: ImageFormat Word32 -> Maybe ImageUsage +requiredFormatUsage (ImageFormat _ [8,8,8,8]) = Nothing +requiredFormatUsage (ImageFormat (Integer Normalised _) [_,_,_,_]) = Just Storage +requiredFormatUsage (ImageFormat _ [i,_,_,l]) + | i == l = Nothing +requiredFormatUsage (ImageFormat _ [32] ) = Nothing +requiredFormatUsage (ImageFormat _ [_ ] ) = Just Storage +requiredFormatUsage _ = Just Storage + + +fromFormat :: ImageFormat Word32 -> Maybe Word32 +fromFormat ( RGBA32 F ) = Just 1 +fromFormat ( RGBA16 F ) = Just 2 +fromFormat ( R32 F ) = Just 3 +fromFormat ( RGBA8 UNorm ) = Just 4 +fromFormat ( RGBA8 SNorm ) = Just 5 +fromFormat ( RG32 F ) = Just 6 +fromFormat ( RG16 F ) = Just 7 +fromFormat ( R11G11B10 F ) = Just 8 +fromFormat ( R16 F ) = Just 9 +fromFormat ( RGBA16 UNorm ) = Just 10 +fromFormat ( RGB10A2 UNorm ) = Just 11 +fromFormat ( RG16 UNorm ) = Just 12 +fromFormat ( RG8 UNorm ) = Just 13 +fromFormat ( R16 UNorm ) = Just 14 +fromFormat ( R8 UNorm ) = Just 15 +fromFormat ( RGBA16 SNorm ) = Just 16 +fromFormat ( RG16 SNorm ) = Just 17 +fromFormat ( RG8 SNorm ) = Just 18 +fromFormat ( R16 SNorm ) = Just 19 +fromFormat ( R8 SNorm ) = Just 20 +fromFormat ( RGBA32 I ) = Just 21 +fromFormat ( RGBA16 I ) = Just 22 +fromFormat ( RGBA8 I ) = Just 23 +fromFormat ( R32 I ) = Just 24 +fromFormat ( RG32 I ) = Just 25 +fromFormat ( RG16 I ) = Just 26 +fromFormat ( RG8 I ) = Just 27 +fromFormat ( R16 I ) = Just 28 +fromFormat ( R8 I ) = Just 29 +fromFormat ( RGBA32 UI ) = Just 30 +fromFormat ( RGBA16 UI ) = Just 31 +fromFormat ( RGBA8 UI ) = Just 32 +fromFormat ( R32 UI ) = Just 33 +fromFormat ( RGB10A2 UI ) = Just 34 +fromFormat ( RG32 UI ) = Just 35 +fromFormat ( RG16 UI ) = Just 36 +fromFormat ( RG8 UI ) = Just 37 +fromFormat ( R16 UI ) = Just 38 +fromFormat ( R8 UI ) = Just 39 +fromFormat _ = Nothing + +instance Put (ImageFormat Word32) where + put format = case fromFormat format of + Just i -> put i + Nothing -> put @Word32 0 + wordCount _ = 1 + +instance Put (Maybe (ImageFormat Word32)) where + put (Just format) = put format + put Nothing = put @Word32 0 + wordCount _ = 1 + +data SamplerAddressing + = ClampToEdge + | Clamp + | Repeat + | RepeatMirrored + deriving stock ( Show, Eq, Ord, Enum, Bounded ) + +instance Put SamplerAddressing where + put = put @Word32 . fromIntegral . succ . fromEnum + wordCount _ = 1 + +instance Put (Maybe SamplerAddressing) where + put (Just addr) = put addr + put Nothing = put @Word32 0 + wordCount _ = 1 + +data FilterMode + = Nearest + | Linear + deriving stock ( Show, Eq, Ord, Enum, Bounded ) + deriving Put via (PutWord32Enum FilterMode) + +instance Demotable SamplerAddressing where + type Demote SamplerAddressing = SamplerAddressing +instance Known SamplerAddressing ClampToEdge where + known = ClampToEdge +instance Known SamplerAddressing Clamp where + known = Clamp +instance Known SamplerAddressing Repeat where + known = Repeat +instance Known SamplerAddressing RepeatMirrored where + known = RepeatMirrored + +instance Demotable FilterMode where + type Demote FilterMode = FilterMode +instance Known FilterMode Nearest where + known = Nearest +instance Known FilterMode Linear where + known = Linear + +data DepthTesting + = NoDepthTest + | DepthTest + deriving stock ( Show, Eq, Ord, Enum, Bounded ) + +instance Demotable DepthTesting where + type Demote DepthTesting = DepthTesting +instance Known DepthTesting NoDepthTest where + known = NoDepthTest +instance Known DepthTesting DepthTest where + known = DepthTest + +data Projection + = Affine + | Projective + deriving stock ( Show, Eq, Ord, Enum, Bounded ) + +instance Demotable Projection where + type Demote Projection = Projection +instance Known Projection Affine where + known = Affine +instance Known Projection Projective where + known = Projective + +data LODOperand + = Bias + | LOD + | Grad + | MinLOD + deriving stock ( Show, Eq, Ord ) + +data Operand + = LODOperand LODOperand + | ConstOffset + | Offset + | ConstOffsets + | Sample + deriving stock ( Show, Eq, Ord ) + +operandBit :: Operand -> Word32 +operandBit (LODOperand Bias ) = 0x01 +operandBit (LODOperand LOD ) = 0x02 +operandBit (LODOperand Grad ) = 0x04 +operandBit ConstOffset = 0x08 +operandBit Offset = 0x10 +operandBit ConstOffsets = 0x20 +operandBit Sample = 0x40 +operandBit (LODOperand MinLOD ) = 0x80 diff --git a/src/SPIRV/Layout.hs b/src/SPIRV/Layout.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Layout.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DerivingStrategies #-} + +{-| +Module: SPIRV.Layout + +This module describes how types are laid out in memory. + +Values have logical types, which carry no layout information. +Memory can impose a layout on the types it contains: for instance, +a structure in a storage buffer must specify the offsets of its members. +In SPIR-V, the same logical type with different layouts gives different types, +which are declared with different decorations. + +-} + +module SPIRV.Layout + ( LayoutRules(..) + , BlockKind(..) + , Layout(..), logical + ) where + +-------------------------------------------------- + +-- | Rules for explicitly laying out types in memory. +data LayoutRules + = BaseAlignment -- ^ Used for storage buffers, push constants and shader record buffers. + | ExtendedAlignment -- ^ Used for uniform buffers. + deriving stock ( Show, Eq, Ord ) + +-- | The kind of an interface block. +data BlockKind + = UserBlock -- ^ A block declared by the user. + | BuiltinBlock -- ^ A block of built-in variables, such as @gl_PerVertex@. + deriving stock ( Show, Eq, Ord ) + +-- | How a type is laid out in memory. +data Layout + = Layout + { layoutRules :: Maybe LayoutRules + -- ^ Rules for explicit offsets and strides, if any. + , blockKind :: Maybe BlockKind + -- ^ Whether the type is an interface block (or an array of interface blocks). + } + deriving stock ( Show, Eq, Ord ) + +-- | The layout of values: no explicit offsets or strides, and not an interface block. +logical :: Layout +logical = Layout { layoutRules = Nothing, blockKind = Nothing } diff --git a/src/SPIRV/Operation.hs b/src/SPIRV/Operation.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Operation.hs @@ -0,0 +1,1265 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE PatternSynonyms #-} + +{-| +Module: SPIRV.Operation + +Raw SPIR-V OpCodes. Used only at the value-level. + +See "SPIRV.PrimOp" which categorises operations. + +-} + +module SPIRV.Operation where + +-- base +import Data.Word + ( Word16, Word32 ) + +-- fir +import SPIRV.Extension + ( ExtInst(GLSL, OpenCL) ) +import qualified SPIRV.Extension + ( ExtInst(DebugPrintf) ) + +-------------------------------------------------- +-- operation data type + +data Operation + = Code Word16 + | ExtCode ExtInst Word32 + deriving stock Eq + +instance Show Operation where + show op@(Code _) = showOperation op + show op@(ExtCode ext _) = "Ext(" ++ show ext ++") " ++ showOperation op + +-------------------------------------------------- +-- operations + +pattern Nop :: Operation +pattern Nop = Code 0 +pattern Undef :: Operation +pattern Undef = Code 1 +-- (optional) annotations +pattern SourceContinued :: Operation +pattern SourceContinued = Code 2 +pattern Source :: Operation +pattern Source = Code 3 +pattern SourceExtension :: Operation +pattern SourceExtension = Code 4 +pattern Name :: Operation +pattern Name = Code 5 +pattern MemberName :: Operation +pattern MemberName = Code 6 +pattern String :: Operation +pattern String = Code 7 +pattern Line :: Operation +pattern Line = Code 8 +-- no 9 +-- extensions +pattern Extension :: Operation +pattern Extension = Code 10 +pattern ExtInstImport :: Operation +pattern ExtInstImport = Code 11 +pattern ExtInst :: Operation +pattern ExtInst = Code 12 +-- no 13 +pattern MemoryModel :: Operation +pattern MemoryModel = Code 14 +pattern EntryPoint :: Operation +pattern EntryPoint = Code 15 +pattern ExecutionMode :: Operation +pattern ExecutionMode = Code 16 +pattern Capability :: Operation +pattern Capability = Code 17 +-- no 18 +-- type constructors +pattern TypeVoid :: Operation +pattern TypeVoid = Code 19 +pattern TypeBool :: Operation +pattern TypeBool = Code 20 +pattern TypeInt :: Operation +pattern TypeInt = Code 21 +pattern TypeFloat :: Operation +pattern TypeFloat = Code 22 +pattern TypeVector :: Operation +pattern TypeVector = Code 23 +pattern TypeMatrix :: Operation +pattern TypeMatrix = Code 24 +pattern TypeImage :: Operation +pattern TypeImage = Code 25 +pattern TypeSampler :: Operation +pattern TypeSampler = Code 26 +pattern TypeSampledImage :: Operation +pattern TypeSampledImage = Code 27 +pattern TypeArray :: Operation +pattern TypeArray = Code 28 +pattern TypeRuntimeArray :: Operation +pattern TypeRuntimeArray = Code 29 +pattern TypeStruct :: Operation +pattern TypeStruct = Code 30 +pattern TypeOpaque :: Operation +pattern TypeOpaque = Code 31 +pattern TypePointer :: Operation +pattern TypePointer = Code 32 +pattern TypeFunction :: Operation +pattern TypeFunction = Code 33 +pattern TypeEvent :: Operation +pattern TypeEvent = Code 34 +pattern TypeDeviceEvent :: Operation +pattern TypeDeviceEvent = Code 35 +pattern TypeReserveId :: Operation +pattern TypeReserveId = Code 36 +pattern TypeQueue :: Operation +pattern TypeQueue = Code 37 +pattern TypePipe :: Operation +pattern TypePipe = Code 38 +pattern TypeForwardPointer :: Operation +pattern TypeForwardPointer = Code 39 +-- no 40 +-- constants +pattern ConstantTrue :: Operation +pattern ConstantTrue = Code 41 +pattern ConstantFalse :: Operation +pattern ConstantFalse = Code 42 +pattern Constant :: Operation +pattern Constant = Code 43 +pattern ConstantComposite :: Operation +pattern ConstantComposite = Code 44 +pattern ConstantSampler :: Operation +pattern ConstantSampler = Code 45 +pattern ConstantNull :: Operation +pattern ConstantNull = Code 46 +-- no 47 +-- specialisation constants +pattern SpecConstantTrue :: Operation +pattern SpecConstantTrue = Code 48 +pattern SpecConstantFalse :: Operation +pattern SpecConstantFalse = Code 49 +pattern SpecConstant :: Operation +pattern SpecConstant = Code 50 +pattern SpecConstantComposite :: Operation +pattern SpecConstantComposite = Code 51 +pattern SpecConstantOp :: Operation +pattern SpecConstantOp = Code 52 +-- no 53 +-- functions +pattern Function :: Operation +pattern Function = Code 54 +pattern FunctionParameter :: Operation +pattern FunctionParameter = Code 55 +pattern FunctionEnd :: Operation +pattern FunctionEnd = Code 56 +pattern FunctionCall :: Operation +pattern FunctionCall = Code 57 +-- no 58 +-- variables & pointers +pattern Variable :: Operation +pattern Variable = Code 59 +pattern ImageTexelPointer :: Operation +pattern ImageTexelPointer = Code 60 +pattern Load :: Operation +pattern Load = Code 61 +pattern Store :: Operation +pattern Store = Code 62 +pattern CopyMemory :: Operation +pattern CopyMemory = Code 63 +pattern CopyMemorySized :: Operation +pattern CopyMemorySized = Code 54 +pattern AccessChain :: Operation +pattern AccessChain = Code 65 +pattern InBoundsAccessChain :: Operation +pattern InBoundsAccessChain = Code 66 +pattern PtrAccessChain :: Operation +pattern PtrAccessChain = Code 67 +pattern ArrayLength :: Operation +pattern ArrayLength = Code 68 +pattern GenericPtrMemSemantics :: Operation +pattern GenericPtrMemSemantics = Code 69 +pattern InBoundsPtrAccessChain :: Operation +pattern InBoundsPtrAccessChain = Code 70 +-- decorations +pattern Decorate :: Operation +pattern Decorate = Code 71 +pattern MemberDecorate :: Operation +pattern MemberDecorate = Code 72 +pattern DecorationGroup :: Operation +pattern DecorationGroup = Code 73 +pattern GroupDecorate :: Operation +pattern GroupDecorate = Code 74 +pattern GroupMemberDecorate :: Operation +pattern GroupMemberDecorate = Code 75 +-- no 76 +-- vector indexing +pattern VectorExtractDynamic :: Operation +pattern VectorExtractDynamic = Code 77 +pattern VectorInsertDynamic :: Operation +pattern VectorInsertDynamic = Code 78 +pattern VectorShuffle :: Operation +pattern VectorShuffle = Code 79 +-- structs +pattern CompositeConstruct :: Operation +pattern CompositeConstruct = Code 80 +pattern CompositeExtract :: Operation +pattern CompositeExtract = Code 81 +pattern CompositeInsert :: Operation +pattern CompositeInsert = Code 82 +pattern CopyObject :: Operation +pattern CopyObject = Code 83 +pattern CopyLogical :: Operation +pattern CopyLogical = Code 400 +-- operation 84 (Transpose) defined later (141.5) +-- no 85 +-- image instructions +pattern SampledImage :: Operation +pattern SampledImage = Code 86 +pattern ImageSampleImplicitLod :: Operation +pattern ImageSampleImplicitLod = Code 87 +pattern ImageSampleExplicitLod :: Operation +pattern ImageSampleExplicitLod = Code 88 +pattern ImageSampleDrefImplicitLod :: Operation +pattern ImageSampleDrefImplicitLod = Code 89 +pattern ImageSampleDrefExplicitLod :: Operation +pattern ImageSampleDrefExplicitLod = Code 90 +pattern ImageSampleProjImplicitLod :: Operation +pattern ImageSampleProjImplicitLod = Code 91 +pattern ImageSampleProjExplicitLod :: Operation +pattern ImageSampleProjExplicitLod = Code 92 +pattern ImageSampleProjDrefImplicitLod :: Operation +pattern ImageSampleProjDrefImplicitLod = Code 93 +pattern ImageSampleProjDrefExplicitLod :: Operation +pattern ImageSampleProjDrefExplicitLod = Code 94 +pattern ImageFetch :: Operation +pattern ImageFetch = Code 95 +pattern ImageGather :: Operation +pattern ImageGather = Code 96 +pattern ImageDrefGather :: Operation +pattern ImageDrefGather = Code 97 +pattern ImageRead :: Operation +pattern ImageRead = Code 98 +pattern ImageWrite :: Operation +pattern ImageWrite = Code 99 +pattern Image :: Operation +pattern Image = Code 100 +-- image queries +pattern ImageQueryFormat :: Operation +pattern ImageQueryFormat = Code 101 +pattern ImageQueryOrder :: Operation +pattern ImageQueryOrder = Code 102 +pattern ImageQuerySizeLod :: Operation +pattern ImageQuerySizeLod = Code 103 +pattern ImageQuerySize :: Operation +pattern ImageQuerySize = Code 104 +pattern ImageQueryLod :: Operation +pattern ImageQueryLod = Code 105 +pattern ImageQueryLevels :: Operation +pattern ImageQueryLevels = Code 106 +pattern ImageQuerySamples :: Operation +pattern ImageQuerySamples = Code 107 +-- sparse image instructions +-- no 108 +-- conversion instructions +pattern ConvertFToU :: Operation +pattern ConvertFToU = Code 109 +pattern ConvertFToS :: Operation +pattern ConvertFToS = Code 110 +pattern ConvertSToF :: Operation +pattern ConvertSToF = Code 111 +pattern ConvertUToF :: Operation +pattern ConvertUToF = Code 112 +pattern UConvert :: Operation +pattern UConvert = Code 113 +pattern SConvert :: Operation +pattern SConvert = Code 114 +pattern FConvert :: Operation +pattern FConvert = Code 115 +pattern SatConvertSToU :: Operation +pattern SatConvertSToU = Code 118 +pattern SatConvertUToS :: Operation +pattern SatConvertUToS = Code 119 +-- pointer casting +-- bit cast +pattern BitCast :: Operation +pattern BitCast = Code 124 +-- no 125 +-- numeric instructions +pattern SNegate :: Operation +pattern SNegate = Code 126 +pattern FNegate :: Operation +pattern FNegate = Code 127 +pattern IAdd :: Operation +pattern IAdd = Code 128 +pattern FAdd :: Operation +pattern FAdd = Code 129 +pattern ISub :: Operation +pattern ISub = Code 130 +pattern FSub :: Operation +pattern FSub = Code 131 +pattern IMul :: Operation +pattern IMul = Code 132 +pattern FMul :: Operation +pattern FMul = Code 133 +pattern UDiv :: Operation +pattern UDiv = Code 134 +pattern SDiv :: Operation +pattern SDiv = Code 135 +pattern FDiv :: Operation +pattern FDiv = Code 136 +pattern UMod :: Operation +pattern UMod = Code 137 +pattern SRem :: Operation +pattern SRem = Code 138 +pattern SMod :: Operation +pattern SMod = Code 139 +pattern FRem :: Operation +pattern FRem = Code 140 +pattern FMod :: Operation +pattern FMod = Code 141 +-- vector and matrix instructions +pattern Transpose :: Operation +pattern Transpose = Code 84 +pattern VectorTimesScalar :: Operation +pattern VectorTimesScalar = Code 142 +pattern MatrixTimesScalar :: Operation +pattern MatrixTimesScalar = Code 143 +pattern VectorTimesMatrix :: Operation +pattern VectorTimesMatrix = Code 144 +pattern MatrixTimesVector :: Operation +pattern MatrixTimesVector = Code 145 +pattern MatrixTimesMatrix :: Operation +pattern MatrixTimesMatrix = Code 146 +pattern OuterProduct :: Operation +pattern OuterProduct = Code 147 +pattern Dot :: Operation +pattern Dot = Code 148 +-- IEEE floating point logical instructions +pattern IsNan :: Operation +pattern IsNan = Code 156 +pattern IsInf :: Operation +pattern IsInf = Code 157 +-- boolean instructions +pattern LogicalEqual :: Operation +pattern LogicalEqual = Code 164 +pattern LogicalNotEqual :: Operation +pattern LogicalNotEqual = Code 165 +pattern LogicalOr :: Operation +pattern LogicalOr = Code 166 +pattern LogicalAnd :: Operation +pattern LogicalAnd = Code 167 +pattern LogicalNot :: Operation +pattern LogicalNot = Code 168 +pattern Select :: Operation +pattern Select = Code 169 +-- integer comparisons +pattern IEqual :: Operation +pattern IEqual = Code 170 +pattern INotEqual :: Operation +pattern INotEqual = Code 171 +pattern UGreaterThan :: Operation +pattern UGreaterThan = Code 172 +pattern SGreaterThan :: Operation +pattern SGreaterThan = Code 173 +pattern UGreaterThanEqual :: Operation +pattern UGreaterThanEqual = Code 174 +pattern SGreaterThanEqual :: Operation +pattern SGreaterThanEqual = Code 175 +pattern ULessThan :: Operation +pattern ULessThan = Code 176 +pattern SLessThan :: Operation +pattern SLessThan = Code 177 +pattern ULessThanEqual :: Operation +pattern ULessThanEqual = Code 178 +pattern SLessThanEqual :: Operation +pattern SLessThanEqual = Code 179 +-- floating point comparisons +pattern FOrdEqual :: Operation +pattern FOrdEqual = Code 180 +pattern FUnordEqual :: Operation +pattern FUnordEqual = Code 181 +pattern FOrdNotEqual :: Operation +pattern FOrdNotEqual = Code 182 +pattern FUnordNotEqual :: Operation +pattern FUnordNotEqual = Code 183 +pattern FOrdLessThan :: Operation +pattern FOrdLessThan = Code 184 +pattern FUnordLessThan :: Operation +pattern FUnordLessThan = Code 185 +pattern FOrdGreaterThan :: Operation +pattern FOrdGreaterThan = Code 186 +pattern FUnordGreaterThan :: Operation +pattern FUnordGreaterThan = Code 187 +pattern FOrdLessThanEqual :: Operation +pattern FOrdLessThanEqual = Code 188 +pattern FUnordLessThanEqual :: Operation +pattern FUnordLessThanEqual = Code 189 +pattern FOrdGreaterThanEqual :: Operation +pattern FOrdGreaterThanEqual = Code 190 +pattern FUnordGreaterThanEqual :: Operation +pattern FUnordGreaterThanEqual = Code 191 +-- bitwise operations +pattern ShiftRightLogical :: Operation +pattern ShiftRightLogical = Code 194 +pattern ShiftRightArithmetic :: Operation +pattern ShiftRightArithmetic = Code 195 +pattern ShiftLeftLogical :: Operation +pattern ShiftLeftLogical = Code 196 +pattern BitwiseOr :: Operation +pattern BitwiseOr = Code 197 +pattern BitwiseXor :: Operation +pattern BitwiseXor = Code 198 +pattern BitwiseAnd :: Operation +pattern BitwiseAnd = Code 199 +pattern Not :: Operation +pattern Not = Code 200 +pattern BitReverse :: Operation +pattern BitReverse = Code 204 +-- geometry primitives +pattern EmitVertex :: Operation +pattern EmitVertex = Code 218 +pattern EndPrimitive :: Operation +pattern EndPrimitive = Code 219 +pattern EmitStreamVertex :: Operation +pattern EmitStreamVertex = Code 220 +pattern EndStreamPrimitive :: Operation +pattern EndStreamPrimitive = Code 221 +-- memory synchronisation +pattern ControlBarrier :: Operation +pattern ControlBarrier = Code 224 +pattern MemoryBarrier :: Operation +pattern MemoryBarrier = Code 225 +-- atomic instructions +pattern AtomicLoad :: Operation +pattern AtomicLoad = Code 227 +pattern AtomicStore :: Operation +pattern AtomicStore = Code 228 +pattern AtomicExchange :: Operation +pattern AtomicExchange = Code 229 +pattern AtomicCompareExchange :: Operation +pattern AtomicCompareExchange = Code 230 +pattern AtomicIIncrement :: Operation +pattern AtomicIIncrement = Code 232 +pattern AtomicIDecrement :: Operation +pattern AtomicIDecrement = Code 233 +pattern AtomicIAdd :: Operation +pattern AtomicIAdd = Code 234 +pattern AtomicISub :: Operation +pattern AtomicISub = Code 235 +pattern AtomicSMin :: Operation +pattern AtomicSMin = Code 236 +pattern AtomicUMin :: Operation +pattern AtomicUMin = Code 237 +pattern AtomicSMax :: Operation +pattern AtomicSMax = Code 238 +pattern AtomicUMax :: Operation +pattern AtomicUMax = Code 239 +pattern AtomicAnd :: Operation +pattern AtomicAnd = Code 240 +pattern AtomicOr :: Operation +pattern AtomicOr = Code 241 +pattern AtomicXor :: Operation +pattern AtomicXor = Code 242 +pattern AtomicFMinEXT :: Operation +pattern AtomicFMinEXT = Code 5614 +pattern AtomicFMaxEXT :: Operation +pattern AtomicFMaxEXT = Code 5615 +pattern AtomicFAddEXT :: Operation +pattern AtomicFAddEXT = Code 6035 +-- group and subgroup operations +pattern GroupAsyncCopy :: Operation +pattern GroupAsyncCopy = Code 259 +pattern GroupWaitEvents :: Operation +pattern GroupWaitEvents = Code 260 +pattern GroupAll :: Operation +pattern GroupAll = Code 261 +pattern GroupAny :: Operation +pattern GroupAny = Code 262 +pattern GroupBroadcast :: Operation +pattern GroupBroadcast = Code 263 +pattern GroupIAdd :: Operation +pattern GroupIAdd = Code 264 +pattern GroupFAdd :: Operation +pattern GroupFAdd = Code 265 +pattern GroupFMin :: Operation +pattern GroupFMin = Code 266 +pattern GroupUMin :: Operation +pattern GroupUMin = Code 267 +pattern GroupSMin :: Operation +pattern GroupSMin = Code 268 +pattern GroupFMax :: Operation +pattern GroupFMax = Code 269 +pattern GroupUMax :: Operation +pattern GroupUMax = Code 270 +pattern GroupSMax :: Operation +pattern GroupSMax = Code 271 + +-- control flow +pattern Phi :: Operation +pattern Phi = Code 245 +pattern LoopMerge :: Operation +pattern LoopMerge = Code 246 +pattern SelectionMerge :: Operation +pattern SelectionMerge = Code 247 +pattern Label :: Operation +pattern Label = Code 248 +pattern Branch :: Operation +pattern Branch = Code 249 +pattern BranchConditional :: Operation +pattern BranchConditional = Code 250 +pattern Switch :: Operation +pattern Switch = Code 251 +pattern Kill :: Operation +pattern Kill = Code 252 +pattern Return :: Operation +pattern Return = Code 253 +pattern ReturnValue :: Operation +pattern ReturnValue = Code 254 +pattern Unreachable :: Operation +pattern Unreachable = Code 255 + +-- non uniform group instructions +pattern GroupNonUniformElect :: Operation +pattern GroupNonUniformElect = Code 333 +pattern GroupNonUniformAll :: Operation +pattern GroupNonUniformAll = Code 334 +pattern GroupNonUniformAny :: Operation +pattern GroupNonUniformAny = Code 335 +pattern GroupNonUniformAllEqual :: Operation +pattern GroupNonUniformAllEqual = Code 336 +pattern GroupNonUniformBroadcast :: Operation +pattern GroupNonUniformBroadcast = Code 337 +pattern GroupNonUniformBroadcastFirst :: Operation +pattern GroupNonUniformBroadcastFirst = Code 338 +pattern GroupNonUniformBallot :: Operation +pattern GroupNonUniformBallot = Code 339 +pattern GroupNonUniformInverseBallot :: Operation +pattern GroupNonUniformInverseBallot = Code 340 +pattern GroupNonUniformBallotBitExtract :: Operation +pattern GroupNonUniformBallotBitExtract = Code 341 +pattern GroupNonUniformBallotBitCount :: Operation +pattern GroupNonUniformBallotBitCount = Code 342 +pattern GroupNonUniformBallotFindLSB :: Operation +pattern GroupNonUniformBallotFindLSB = Code 343 +pattern GroupNonUniformBallotFindMSB :: Operation +pattern GroupNonUniformBallotFindMSB = Code 344 +pattern GroupNonUniformShuffle :: Operation +pattern GroupNonUniformShuffle = Code 345 +pattern GroupNonUniformShuffleXor :: Operation +pattern GroupNonUniformShuffleXor = Code 346 +pattern GroupNonUniformShuffleUp :: Operation +pattern GroupNonUniformShuffleUp = Code 347 +pattern GroupNonUniformShuffleDown :: Operation +pattern GroupNonUniformShuffleDown = Code 348 +pattern GroupNonUniformIAdd :: Operation +pattern GroupNonUniformIAdd = Code 349 +pattern GroupNonUniformFAdd :: Operation +pattern GroupNonUniformFAdd = Code 350 +pattern GroupNonUniformIMul :: Operation +pattern GroupNonUniformIMul = Code 351 +pattern GroupNonUniformFMul :: Operation +pattern GroupNonUniformFMul = Code 352 +pattern GroupNonUniformSMin :: Operation +pattern GroupNonUniformSMin = Code 353 +pattern GroupNonUniformUMin :: Operation +pattern GroupNonUniformUMin = Code 354 +pattern GroupNonUniformFMin :: Operation +pattern GroupNonUniformFMin = Code 355 +pattern GroupNonUniformSMax :: Operation +pattern GroupNonUniformSMax = Code 356 +pattern GroupNonUniformUMax :: Operation +pattern GroupNonUniformUMax = Code 357 +pattern GroupNonUniformFMax :: Operation +pattern GroupNonUniformFMax = Code 358 +pattern GroupNonUniformBitwiseAnd :: Operation +pattern GroupNonUniformBitwiseAnd = Code 359 +pattern GroupNonUniformBitwiseOr :: Operation +pattern GroupNonUniformBitwiseOr = Code 360 +pattern GroupNonUniformBitwiseXor :: Operation +pattern GroupNonUniformBitwiseXor = Code 361 +pattern GroupNonUniformLogicalAnd :: Operation +pattern GroupNonUniformLogicalAnd = Code 362 +pattern GroupNonUniformLogicalOr :: Operation +pattern GroupNonUniformLogicalOr = Code 363 +pattern GroupNonUniformLogicalXor :: Operation +pattern GroupNonUniformLogicalXor = Code 364 +pattern GroupNonUniformQuadBroadcast :: Operation +pattern GroupNonUniformQuadBroadcast = Code 365 +pattern GroupNonUniformQuadSwap :: Operation +pattern GroupNonUniformQuadSwap = Code 366 + + +-- ray tracing instructions +pattern TraceRay :: Operation +pattern TraceRay = Code 4445 +pattern ExecuteCallable :: Operation +pattern ExecuteCallable = Code 4446 +pattern ConvertUToAccelerationStructure :: Operation +pattern ConvertUToAccelerationStructure = Code 4447 +pattern IgnoreIntersection :: Operation +pattern IgnoreIntersection = Code 4448 +pattern TerminateRay :: Operation +pattern TerminateRay = Code 4449 +pattern ReportIntersection :: Operation +pattern ReportIntersection = Code 5334 +pattern TypeAccelerationStructure :: Operation +pattern TypeAccelerationStructure = Code 5341 +-- ray query instructions +pattern TypeRayQuery :: Operation +pattern TypeRayQuery = Code 4472 +pattern RayQueryInitialize :: Operation +pattern RayQueryInitialize = Code 4473 +pattern RayQueryTerminate :: Operation +pattern RayQueryTerminate = Code 4474 +pattern RayQueryGenerateIntersection :: Operation +pattern RayQueryGenerateIntersection = Code 4475 +pattern RayQueryConfirmIntersection :: Operation +pattern RayQueryConfirmIntersection = Code 4476 +pattern RayQueryProceed :: Operation +pattern RayQueryProceed = Code 4477 +pattern RayQueryGetIntersectionType :: Operation +pattern RayQueryGetIntersectionType = Code 4479 +pattern RayQueryGetRayTMin :: Operation +pattern RayQueryGetRayTMin = Code 6016 +pattern RayQueryGetRayFlags :: Operation +pattern RayQueryGetRayFlags = Code 6017 +pattern RayQueryGetIntersectionT :: Operation +pattern RayQueryGetIntersectionT = Code 6018 +pattern RayQueryGetIntersectionInstanceCustomIndex :: Operation +pattern RayQueryGetIntersectionInstanceCustomIndex = Code 6019 +pattern RayQueryGetIntersectionInstanceId :: Operation +pattern RayQueryGetIntersectionInstanceId = Code 6020 +pattern RayQueryGetIntersectionInstanceShaderBindingTableRecordOffset :: Operation +pattern RayQueryGetIntersectionInstanceShaderBindingTableRecordOffset = Code 6021 +pattern RayQueryGetIntersectionGeometryIndex :: Operation +pattern RayQueryGetIntersectionGeometryIndex = Code 6022 +pattern RayQueryGetIntersectionPrimitiveIndex :: Operation +pattern RayQueryGetIntersectionPrimitiveIndex = Code 6023 +pattern RayQueryGetIntersectionBarycentrics :: Operation +pattern RayQueryGetIntersectionBarycentrics = Code 6024 +pattern RayQueryGetIntersectionFrontFace :: Operation +pattern RayQueryGetIntersectionFrontFace = Code 6025 +pattern RayQueryGetIntersectionCandidateAABBOpaque :: Operation +pattern RayQueryGetIntersectionCandidateAABBOpaque = Code 6026 +pattern RayQueryGetIntersectionObjectRayDirection :: Operation +pattern RayQueryGetIntersectionObjectRayDirection = Code 6027 +pattern RayQueryGetIntersectionObjectRayOrigin :: Operation +pattern RayQueryGetIntersectionObjectRayOrigin = Code 6028 +pattern RayQueryGetWorldRayDirection :: Operation +pattern RayQueryGetWorldRayDirection = Code 6029 +pattern RayQueryGetWorldRayOrigin :: Operation +pattern RayQueryGetWorldRayOrigin = Code 6030 +pattern RayQueryGetIntersectionObjectToWorld :: Operation +pattern RayQueryGetIntersectionObjectToWorld = Code 6031 +pattern RayQueryGetIntersectionWorldToObject :: Operation +pattern RayQueryGetIntersectionWorldToObject = Code 6032 +-- GLSL extended instructions +pattern GLSL_Round :: Operation +pattern GLSL_Round = ExtCode GLSL 1 +pattern GLSL_RoundEven :: Operation +pattern GLSL_RoundEven = ExtCode GLSL 2 +pattern GLSL_Trunc :: Operation +pattern GLSL_Trunc = ExtCode GLSL 3 +pattern GLSL_FAbs :: Operation +pattern GLSL_FAbs = ExtCode GLSL 4 +pattern GLSL_SAbs :: Operation +pattern GLSL_SAbs = ExtCode GLSL 5 +pattern GLSL_FSign :: Operation +pattern GLSL_FSign = ExtCode GLSL 6 +pattern GLSL_SSign :: Operation +pattern GLSL_SSign = ExtCode GLSL 7 +pattern GLSL_Floor :: Operation +pattern GLSL_Floor = ExtCode GLSL 8 +pattern GLSL_Ceil :: Operation +pattern GLSL_Ceil = ExtCode GLSL 9 +pattern GLSL_Fract :: Operation +pattern GLSL_Fract = ExtCode GLSL 10 +pattern GLSL_Sin :: Operation +pattern GLSL_Sin = ExtCode GLSL 13 +pattern GLSL_Cos :: Operation +pattern GLSL_Cos = ExtCode GLSL 14 +pattern GLSL_Tan :: Operation +pattern GLSL_Tan = ExtCode GLSL 15 +pattern GLSL_Asin :: Operation +pattern GLSL_Asin = ExtCode GLSL 16 +pattern GLSL_Acos :: Operation +pattern GLSL_Acos = ExtCode GLSL 17 +pattern GLSL_Atan :: Operation +pattern GLSL_Atan = ExtCode GLSL 18 +pattern GLSL_Sinh :: Operation +pattern GLSL_Sinh = ExtCode GLSL 19 +pattern GLSL_Cosh :: Operation +pattern GLSL_Cosh = ExtCode GLSL 20 +pattern GLSL_Tanh :: Operation +pattern GLSL_Tanh = ExtCode GLSL 21 +pattern GLSL_Asinh :: Operation +pattern GLSL_Asinh = ExtCode GLSL 22 +pattern GLSL_Acosh :: Operation +pattern GLSL_Acosh = ExtCode GLSL 23 +pattern GLSL_Atanh :: Operation +pattern GLSL_Atanh = ExtCode GLSL 24 +pattern GLSL_Atan2 :: Operation +pattern GLSL_Atan2 = ExtCode GLSL 25 +pattern GLSL_Pow :: Operation +pattern GLSL_Pow = ExtCode GLSL 26 +pattern GLSL_Exp :: Operation +pattern GLSL_Exp = ExtCode GLSL 27 +pattern GLSL_Log :: Operation +pattern GLSL_Log = ExtCode GLSL 28 +pattern GLSL_Sqrt :: Operation +pattern GLSL_Sqrt = ExtCode GLSL 31 +pattern GLSL_InvSqrt :: Operation +pattern GLSL_InvSqrt = ExtCode GLSL 32 +pattern GLSL_Determinant :: Operation +pattern GLSL_Determinant = ExtCode GLSL 33 +pattern GLSL_MatrixInverse :: Operation +pattern GLSL_MatrixInverse = ExtCode GLSL 34 +pattern GLSL_FMin :: Operation +pattern GLSL_FMin = ExtCode GLSL 37 +pattern GLSL_UMin :: Operation +pattern GLSL_UMin = ExtCode GLSL 38 +pattern GLSL_SMin :: Operation +pattern GLSL_SMin = ExtCode GLSL 39 +pattern GLSL_FMax :: Operation +pattern GLSL_FMax = ExtCode GLSL 40 +pattern GLSL_UMax :: Operation +pattern GLSL_UMax = ExtCode GLSL 41 +pattern GLSL_SMax :: Operation +pattern GLSL_SMax = ExtCode GLSL 42 +pattern GLSL_Cross :: Operation +pattern GLSL_Cross = ExtCode GLSL 68 +pattern GLSL_Normalize :: Operation +pattern GLSL_Normalize = ExtCode GLSL 69 +-- OpenCL extended instructions + -- floating point instructions +pattern OpenCL_Acos :: Operation +pattern OpenCL_Acos = ExtCode OpenCL 0 +pattern OpenCL_Acosh :: Operation +pattern OpenCL_Acosh = ExtCode OpenCL 1 +pattern OpenCL_Asin :: Operation +pattern OpenCL_Asin = ExtCode OpenCL 3 +pattern OpenCL_Asinh :: Operation +pattern OpenCL_Asinh = ExtCode OpenCL 4 +pattern OpenCL_Atan :: Operation +pattern OpenCL_Atan = ExtCode OpenCL 6 +pattern OpenCL_Atan2 :: Operation +pattern OpenCL_Atan2 = ExtCode OpenCL 7 +pattern OpenCL_Atanh :: Operation +pattern OpenCL_Atanh = ExtCode OpenCL 8 +pattern OpenCL_Cbrt :: Operation +pattern OpenCL_Cbrt = ExtCode OpenCL 11 +pattern OpenCL_Ceil :: Operation +pattern OpenCL_Ceil = ExtCode OpenCL 12 +pattern OpenCL_Cos :: Operation +pattern OpenCL_Cos = ExtCode OpenCL 14 +pattern OpenCL_Cosh :: Operation +pattern OpenCL_Cosh = ExtCode OpenCL 15 +pattern OpenCL_Erfc :: Operation +pattern OpenCL_Erfc = ExtCode OpenCL 17 +pattern OpenCL_Erf :: Operation +pattern OpenCL_Erf = ExtCode OpenCL 18 +pattern OpenCL_Exp :: Operation +pattern OpenCL_Exp = ExtCode OpenCL 19 +pattern OpenCL_Exp2 :: Operation +pattern OpenCL_Exp2 = ExtCode OpenCL 20 +pattern OpenCL_Exp10 :: Operation +pattern OpenCL_Exp10 = ExtCode OpenCL 21 +pattern OpenCL_Expm1 :: Operation +pattern OpenCL_Expm1 = ExtCode OpenCL 22 +pattern OpenCL_FAbs :: Operation +pattern OpenCL_FAbs = ExtCode OpenCL 23 +pattern OpenCL_FDim :: Operation +pattern OpenCL_FDim = ExtCode OpenCL 24 +pattern OpenCL_Floor :: Operation +pattern OpenCL_Floor = ExtCode OpenCL 25 +pattern OpenCL_FMAdd :: Operation +pattern OpenCL_FMAdd = ExtCode OpenCL 26 +pattern OpenCL_FMax :: Operation +pattern OpenCL_FMax = ExtCode OpenCL 27 +pattern OpenCL_FMin :: Operation +pattern OpenCL_FMin = ExtCode OpenCL 28 +pattern OpenCL_FMod :: Operation +pattern OpenCL_FMod = ExtCode OpenCL 29 +pattern OpenCL_Fract :: Operation +pattern OpenCL_Fract = ExtCode OpenCL 30 +pattern OpenCL_FRExp :: Operation +pattern OpenCL_FRExp = ExtCode OpenCL 31 +pattern OpenCL_Hypot :: Operation +pattern OpenCL_Hypot = ExtCode OpenCL 32 +pattern OpenCL_LogGamma :: Operation +pattern OpenCL_LogGamma = ExtCode OpenCL 35 +pattern OpenCL_Log :: Operation +pattern OpenCL_Log = ExtCode OpenCL 37 +pattern OpenCL_Log2 :: Operation +pattern OpenCL_Log2 = ExtCode OpenCL 38 +pattern OpenCL_Log10 :: Operation +pattern OpenCL_Log10 = ExtCode OpenCL 39 +pattern OpenCL_Log1P :: Operation +pattern OpenCL_Log1P = ExtCode OpenCL 40 +pattern OpenCL_LogB :: Operation +pattern OpenCL_LogB = ExtCode OpenCL 41 +pattern OpenCL_MAdd :: Operation +pattern OpenCL_MAdd = ExtCode OpenCL 42 +pattern OpenCL_MaxMag :: Operation +pattern OpenCL_MaxMag = ExtCode OpenCL 43 +pattern OpenCL_MinMag :: Operation +pattern OpenCL_MinMag = ExtCode OpenCL 44 +pattern OpenCL_ModF :: Operation +pattern OpenCL_ModF = ExtCode OpenCL 45 +pattern OpenCL_NaN :: Operation +pattern OpenCL_NaN = ExtCode OpenCL 46 +pattern OpenCL_NextAfter :: Operation +pattern OpenCL_NextAfter = ExtCode OpenCL 47 +pattern OpenCL_Pow :: Operation +pattern OpenCL_Pow = ExtCode OpenCL 48 +pattern OpenCL_FRem :: Operation +pattern OpenCL_FRem = ExtCode OpenCL 51 +pattern OpenCL_FRemQuot :: Operation +pattern OpenCL_FRemQuot = ExtCode OpenCL 52 +pattern OpenCL_RoundEven :: Operation +pattern OpenCL_RoundEven = ExtCode OpenCL 53 +pattern OpenCL_Round :: Operation +pattern OpenCL_Round = ExtCode OpenCL 55 +pattern OpenCL_InvSqrt :: Operation +pattern OpenCL_InvSqrt = ExtCode OpenCL 56 +pattern OpenCL_Sin :: Operation +pattern OpenCL_Sin = ExtCode OpenCL 57 +pattern OpenCL_SinCos :: Operation +pattern OpenCL_SinCos = ExtCode OpenCL 58 +pattern OpenCL_Sinh :: Operation +pattern OpenCL_Sinh = ExtCode OpenCL 59 +pattern OpenCL_Sqrt :: Operation +pattern OpenCL_Sqrt = ExtCode OpenCL 61 +pattern OpenCL_Tan :: Operation +pattern OpenCL_Tan = ExtCode OpenCL 62 +pattern OpenCL_Tanh :: Operation +pattern OpenCL_Tanh = ExtCode OpenCL 63 +pattern OpenCL_Gamma :: Operation +pattern OpenCL_Gamma = ExtCode OpenCL 65 +pattern OpenCL_Trunc :: Operation +pattern OpenCL_Trunc = ExtCode OpenCL 66 +pattern OpenCL_FSign :: Operation +pattern OpenCL_FSign = ExtCode OpenCL 103 + -- integral instructions +pattern OpenCL_SAbs :: Operation +pattern OpenCL_SAbs = ExtCode OpenCL 141 +pattern OpenCL_SAbsDiff :: Operation +pattern OpenCL_SAbsDiff = ExtCode OpenCL 142 +pattern OpenCL_SMax :: Operation +pattern OpenCL_SMax = ExtCode OpenCL 156 +pattern OpenCL_UMax :: Operation +pattern OpenCL_UMax = ExtCode OpenCL 157 +pattern OpenCL_SMin :: Operation +pattern OpenCL_SMin = ExtCode OpenCL 158 +pattern OpenCL_UMin :: Operation +pattern OpenCL_UMin = ExtCode OpenCL 159 +pattern OpenCL_UAbs :: Operation +pattern OpenCL_UAbs = ExtCode OpenCL 201 +pattern OpenCL_UAbsDiff :: Operation +pattern OpenCL_UAbsDiff = ExtCode OpenCL 202 + -- vectors and matrices +pattern OpenCL_Cross :: Operation +pattern OpenCL_Cross = ExtCode OpenCL 104 +pattern OpenCL_Normalize :: Operation +pattern OpenCL_Normalize = ExtCode OpenCL 107 +-- Non-semantic DebugPrintf instruction +pattern DebugPrintf :: Operation +pattern DebugPrintf = ExtCode SPIRV.Extension.DebugPrintf 1 + +-- | Whether an operation is a block termination instruction. +isBlockTerminator :: Operation -> Bool +isBlockTerminator op = op `elem` + [ Branch, BranchConditional, Switch + , Return, ReturnValue + , Kill, Unreachable + , IgnoreIntersection, TerminateRay + ] + +showOperation :: Operation -> String +showOperation Nop = "Nop" +showOperation Undef = "Undef" +showOperation SourceContinued = "SourceContinued" +showOperation Source = "Source" +showOperation SourceExtension = "SourceExtension" +showOperation Name = "Name" +showOperation MemberName = "MemberName" +showOperation String = "String" +showOperation Line = "Line" +showOperation ExtInst = "ExtInst" +showOperation ExtInstImport = "ExtInstImport" +showOperation MemoryModel = "MemoryModel" +showOperation EntryPoint = "EntryPoint" +showOperation ExecutionMode = "ExecutionMode" +showOperation Capability = "Capability" +showOperation TypeVoid = "TypeVoid" +showOperation TypeBool = "TypeBool" +showOperation TypeInt = "TypeInt" +showOperation TypeFloat = "TypeFloat" +showOperation TypeVector = "TypeVector" +showOperation TypeMatrix = "TypeMatrix" +showOperation TypeImage = "TypeImage" +showOperation TypeSampler = "TypeSampler" +showOperation TypeSampledImage = "TypeSampledImage" +showOperation TypeArray = "TypeArray" +showOperation TypeRuntimeArray = "TypeRuntimeArray" +showOperation TypeStruct = "TypeStruct" +showOperation TypeOpaque = "TypeOpaque" +showOperation TypePointer = "TypePointer" +showOperation TypeFunction = "TypeFunction" +showOperation TypeEvent = "TypeEvent" +showOperation TypeDeviceEvent = "TypeDeviceEvent" +showOperation TypeReserveId = "TypeReserveId" +showOperation TypeQueue = "TypeQueue" +showOperation TypePipe = "TypePipe" +showOperation TypeForwardPointer = "TypeForwardPointer" +showOperation ConstantTrue = "ConstantTrue" +showOperation ConstantFalse = "ConstantFalse" +showOperation Constant = "Constant" +showOperation ConstantComposite = "ConstantComposite" +showOperation ConstantSampler = "ConstantSampler" +showOperation ConstantNull = "ConstantNull" +showOperation SpecConstantTrue = "SpecConstantTrue" +showOperation SpecConstantFalse = "SpecConstantFalse" +showOperation SpecConstant = "SpecConstant" +showOperation SpecConstantComposite = "SpecConstantComposite" +showOperation SpecConstantOp = "SpecConstantOp" +showOperation Function = "Function" +showOperation FunctionParameter = "FunctionParameter" +showOperation FunctionEnd = "FunctionEnd" +showOperation FunctionCall = "FunctionCall" +showOperation Variable = "Variable" +showOperation ImageTexelPointer = "ImageTexelPointer" +showOperation Load = "Load" +showOperation Store = "Store" +showOperation CopyMemory = "CopyMemory" +showOperation CopyMemorySized = "CopyMemorySized" +showOperation AccessChain = "AccessChain" +showOperation InBoundsAccessChain = "InBoundsAccessChain" +showOperation PtrAccessChain = "PtrAccessChain" +showOperation ArrayLength = "ArrayLength" +showOperation GenericPtrMemSemantics = "GenericPtrMemSemantics" +showOperation InBoundsPtrAccessChain = "InBoundsPtrAccessChain" +showOperation Decorate = "Decorate" +showOperation MemberDecorate = "MemberDecorate" +showOperation DecorationGroup = "DecorationGroup" +showOperation GroupDecorate = "GroupDecorate" +showOperation GroupMemberDecorate = "GroupMemberDecorate" +showOperation VectorExtractDynamic = "VectorExtractDynamic" +showOperation VectorInsertDynamic = "VectorInsertDynamic" +showOperation VectorShuffle = "VectorShuffle" +showOperation CompositeConstruct = "CompositeConstruct" +showOperation CompositeExtract = "CompositeExtract" +showOperation CompositeInsert = "CompositeInsert" +showOperation CopyObject = "CopyObject" +showOperation CopyLogical = "CopyLogical" +showOperation SampledImage = "SampledImage" +showOperation ImageSampleImplicitLod = "ImageSampleImplicitLod" +showOperation ImageSampleExplicitLod = "ImageSampleExplicitLod" +showOperation ImageSampleDrefImplicitLod = "ImageSampleDrefImplicitLod" +showOperation ImageSampleDrefExplicitLod = "ImageSampleDrefExplicitLod" +showOperation ImageSampleProjImplicitLod = "ImageSampleProjImplicitLod" +showOperation ImageSampleProjExplicitLod = "ImageSampleProjExplicitLod" +showOperation ImageSampleProjDrefImplicitLod = "ImageSampleProjDrefImplicitLod" +showOperation ImageSampleProjDrefExplicitLod = "ImageSampleProjDrefExplicitLod" +showOperation ImageFetch = "ImageFetch" +showOperation ImageGather = "ImageGather" +showOperation ImageDrefGather = "ImageDrefGather" +showOperation ImageRead = "ImageRead" +showOperation ImageWrite = "ImageWrite" +showOperation Image = "Image" +showOperation ImageQueryFormat = "ImageQueryFormat" +showOperation ImageQueryOrder = "ImageQueryOrder" +showOperation ImageQuerySizeLod = "ImageQuerySizeLod" +showOperation ImageQuerySize = "ImageQuerySize" +showOperation ImageQueryLod = "ImageQueryLod" +showOperation ImageQueryLevels = "ImageQueryLevels" +showOperation ImageQuerySamples = "ImageQuerySamples" +showOperation ConvertFToU = "ConvertFToU" +showOperation ConvertFToS = "ConvertFToS" +showOperation ConvertSToF = "ConvertSToF" +showOperation ConvertUToF = "ConvertUToF" +showOperation UConvert = "UConvert" +showOperation SConvert = "SConvert" +showOperation FConvert = "FConvert" +showOperation SatConvertSToU = "SatConvertSToU" +showOperation SatConvertUToS = "SatConvertUToS" +showOperation BitCast = "BitCast" +showOperation SNegate = "SNegate" +showOperation FNegate = "FNegate" +showOperation IAdd = "IAdd" +showOperation FAdd = "FAdd" +showOperation ISub = "ISub" +showOperation FSub = "FSub" +showOperation IMul = "IMul" +showOperation FMul = "FMul" +showOperation UDiv = "UDiv" +showOperation SDiv = "SDiv" +showOperation FDiv = "FDiv" +showOperation UMod = "UMod" +showOperation SRem = "SRem" +showOperation SMod = "SMod" +showOperation FRem = "FRem" +showOperation FMod = "FMod" +showOperation Transpose = "Transpose" +showOperation VectorTimesScalar = "VectorTimesScalar" +showOperation MatrixTimesScalar = "MatrixTimesScalar" +showOperation VectorTimesMatrix = "VectorTimesMatrix" +showOperation MatrixTimesVector = "MatrixTimesVector" +showOperation MatrixTimesMatrix = "MatrixTimesMatrix" +showOperation OuterProduct = "OuterProduct" +showOperation Dot = "Dot" +showOperation LogicalEqual = "LogicalEqual" +showOperation LogicalNotEqual = "LogicalNotEqual" +showOperation LogicalOr = "LogicalOr" +showOperation LogicalAnd = "LogicalAnd" +showOperation LogicalNot = "LogicalNot" +showOperation IEqual = "IEqual" +showOperation INotEqual = "INotEqual" +showOperation UGreaterThan = "UGreaterThan" +showOperation SGreaterThan = "SGreaterThan" +showOperation UGreaterThanEqual = "UGreaterThanEqual" +showOperation SGreaterThanEqual = "SGreaterThanEqual" +showOperation ULessThan = "ULessThan" +showOperation SLessThan = "SLessThan" +showOperation ULessThanEqual = "ULessThanEqual" +showOperation SLessThanEqual = "SLessThanEqual" +showOperation FOrdEqual = "FOrdEqual" +showOperation FUnordEqual = "FUnordEqual" +showOperation FOrdNotEqual = "FOrdNotEqual" +showOperation FUnordNotEqual = "FUnordNotEqual" +showOperation FOrdLessThan = "FOrdLessThan" +showOperation FUnordLessThan = "FUnordLessThan" +showOperation FOrdGreaterThan = "FOrdGreaterThan" +showOperation FUnordGreaterThan = "FUnordGreaterThan" +showOperation FOrdLessThanEqual = "FOrdLessThanEqual" +showOperation FUnordLessThanEqual = "FUnordLessThanEqual" +showOperation FOrdGreaterThanEqual = "FOrdGreaterThanEqual" +showOperation FUnordGreaterThanEqual = "FUnordGreaterThanEqual" +showOperation ShiftRightLogical = "ShiftRightLogical" +showOperation ShiftRightArithmetic = "ShiftRightArithmetic" +showOperation ShiftLeftLogical = "ShiftLeftLogical" +showOperation BitwiseOr = "BitwiseOr" +showOperation BitwiseXor = "BitwiseXor" +showOperation BitwiseAnd = "BitwiseAnd" +showOperation Not = "Not" +showOperation BitReverse = "BitReverse" +showOperation EmitVertex = "EmitVertex" +showOperation EndPrimitive = "EndPrimitive" +showOperation EmitStreamVertex = "EmitStreamVertex" +showOperation EndStreamPrimitive = "EndStreamPrimitive" +showOperation AtomicLoad = "AtomicLoad" +showOperation AtomicStore = "AtomicStore" +showOperation AtomicExchange = "AtomicExchange" +showOperation AtomicCompareExchange = "AtomicCompareExchange" +showOperation AtomicIIncrement = "AtomicIIncrement" +showOperation AtomicIDecrement = "AtomicIDecrement" +showOperation AtomicIAdd = "AtomicIAdd" +showOperation AtomicISub = "AtomicISub" +showOperation AtomicSMin = "AtomicSMin" +showOperation AtomicUMin = "AtomicUMin" +showOperation AtomicSMax = "AtomicSMax" +showOperation AtomicUMax = "AtomicUMax" +showOperation AtomicAnd = "AtomicAnd" +showOperation AtomicOr = "AtomicOr" +showOperation AtomicXor = "AtomicXor" +showOperation AtomicFMinEXT = "AtomicFMinEXT" +showOperation AtomicFMaxEXT = "AtomicFMaxEXT" +showOperation AtomicFAddEXT = "AtomicFAddEXT" +showOperation GroupAsyncCopy = "GroupAsyncCopy" +showOperation GroupWaitEvents = "GroupWaitEvents" +showOperation GroupAll = "GroupAll" +showOperation GroupAny = "GroupAny" +showOperation GroupBroadcast = "GroupBroadcast" +showOperation GroupIAdd = "GroupIAdd" +showOperation GroupFAdd = "GroupFAdd" +showOperation GroupFMin = "GroupFMin" +showOperation GroupUMin = "GroupUMin" +showOperation GroupSMin = "GroupSMin" +showOperation GroupFMax = "GroupFMax" +showOperation GroupUMax = "GroupUMax" +showOperation GroupSMax = "GroupSMax" +showOperation Phi = "Phi" +showOperation LoopMerge = "LoopMerge" +showOperation SelectionMerge = "SelectionMerge" +showOperation Label = "Label" +showOperation Branch = "Branch" +showOperation BranchConditional = "BranchConditional" +showOperation Switch = "Switch" +showOperation Kill = "Kill" +showOperation Return = "Return" +showOperation ReturnValue = "ReturnValue" +showOperation Unreachable = "Unreachable" +-- non uniform group instructions +showOperation GroupNonUniformElect = "GroupNonUniformElect" +showOperation GroupNonUniformAll = "GroupNonUniformAll" +showOperation GroupNonUniformAny = "GroupNonUniformAny" +showOperation GroupNonUniformAllEqual = "GroupNonUniformAllEqual" +showOperation GroupNonUniformBroadcast = "GroupNonUniformBroadcast" +showOperation GroupNonUniformBroadcastFirst = "GroupNonUniformBroadcastFirst" +showOperation GroupNonUniformBallot = "GroupNonUniformBallot" +showOperation GroupNonUniformInverseBallot = "GroupNonUniformInverseBallot" +showOperation GroupNonUniformBallotBitExtract = "GroupNonUniformBallotBitExtract" +showOperation GroupNonUniformBallotBitCount = "GroupNonUniformBallotBitCount" +showOperation GroupNonUniformBallotFindLSB = "GroupNonUniformBallotFindLSB" +showOperation GroupNonUniformBallotFindMSB = "GroupNonUniformBallotFindMSB" +showOperation GroupNonUniformShuffle = "GroupNonUniformShuffle" +showOperation GroupNonUniformShuffleXor = "GroupNonUniformShuffleXor" +showOperation GroupNonUniformShuffleUp = "GroupNonUniformShuffleUp" +showOperation GroupNonUniformShuffleDown = "GroupNonUniformShuffleDown" +showOperation GroupNonUniformIAdd = "GroupNonUniformIAdd" +showOperation GroupNonUniformFAdd = "GroupNonUniformFAdd" +showOperation GroupNonUniformIMul = "GroupNonUniformIMul" +showOperation GroupNonUniformFMul = "GroupNonUniformFMul" +showOperation GroupNonUniformSMin = "GroupNonUniformSMin" +showOperation GroupNonUniformUMin = "GroupNonUniformUMin" +showOperation GroupNonUniformFMin = "GroupNonUniformFMin" +showOperation GroupNonUniformSMax = "GroupNonUniformSMax" +showOperation GroupNonUniformUMax = "GroupNonUniformUMax" +showOperation GroupNonUniformFMax = "GroupNonUniformFMax" +showOperation GroupNonUniformBitwiseAnd = "GroupNonUniformBitwiseAnd" +showOperation GroupNonUniformBitwiseOr = "GroupNonUniformBitwiseOr" +showOperation GroupNonUniformBitwiseXor = "GroupNonUniformBitwiseXor" +showOperation GroupNonUniformLogicalAnd = "GroupNonUniformLogicalAnd" +showOperation GroupNonUniformLogicalOr = "GroupNonUniformLogicalOr" +showOperation GroupNonUniformLogicalXor = "GroupNonUniformLogicalXor" +showOperation GroupNonUniformQuadBroadcast = "GroupNonUniformQuadBroadcast" +showOperation GroupNonUniformQuadSwap = "GroupNonUniformQuadSwap" +-- ray tracing instructions +showOperation TraceRay = "TraceRay" +showOperation ExecuteCallable = "ExecuteCallable" +showOperation ConvertUToAccelerationStructure = "ConvertUToAccelerationStructure" +showOperation IgnoreIntersection = "IgnoreIntersection" +showOperation TerminateRay = "TerminateRay" +showOperation ReportIntersection = "ReportIntersection" +showOperation TypeAccelerationStructure = "TypeAccelerationStructure" +-- ray query instructions +showOperation TypeRayQuery = "TypeRayQuery" +showOperation RayQueryInitialize = "RayQueryInitialize" +showOperation RayQueryTerminate = "RayQueryTerminate" +showOperation RayQueryGenerateIntersection = "RayQueryGenerateIntersection" +showOperation RayQueryConfirmIntersection = "RayQueryConfirmIntersection" +showOperation RayQueryProceed = "RayQueryProceed" +showOperation RayQueryGetIntersectionType = "RayQueryGetIntersectionType" +showOperation RayQueryGetRayTMin = "RayQueryGetRayTMin" +showOperation RayQueryGetRayFlags = "RayQueryGetRayFlags" +showOperation RayQueryGetIntersectionT = "RayQueryGetIntersectionT" +showOperation RayQueryGetIntersectionInstanceCustomIndex = "RayQueryGetIntersectionInstanceCustomIndex" +showOperation RayQueryGetIntersectionInstanceId = "RayQueryGetIntersectionInstanceId" +showOperation RayQueryGetIntersectionInstanceShaderBindingTableRecordOffset = "RayQueryGetIntersectionInstanceShaderBindingTableRecordOffset" +showOperation RayQueryGetIntersectionGeometryIndex = "RayQueryGetIntersectionGeometryIndex" +showOperation RayQueryGetIntersectionPrimitiveIndex = "RayQueryGetIntersectionPrimitiveIndex" +showOperation RayQueryGetIntersectionBarycentrics = "RayQueryGetIntersectionBarycentrics" +showOperation RayQueryGetIntersectionFrontFace = "RayQueryGetIntersectionFrontFace" +showOperation RayQueryGetIntersectionCandidateAABBOpaque = "RayQueryGetIntersectionCandidateAABBOpaque" +showOperation RayQueryGetIntersectionObjectRayDirection = "RayQueryGetIntersectionObjectRayDirection" +showOperation RayQueryGetIntersectionObjectRayOrigin = "RayQueryGetIntersectionObjectRayOrigin" +showOperation RayQueryGetWorldRayDirection = "RayQueryGetWorldRayDirection" +showOperation RayQueryGetWorldRayOrigin = "RayQueryGetWorldRayOrigin" +showOperation RayQueryGetIntersectionObjectToWorld = "RayQueryGetIntersectionObjectToWorld" +showOperation RayQueryGetIntersectionWorldToObject = "RayQueryGetIntersectionWorldToObject" +-- GLSL instructions +showOperation GLSL_Round = "Round" +showOperation GLSL_RoundEven = "RoundEven" +showOperation GLSL_Trunc = "Trunc" +showOperation GLSL_FAbs = "FAbs" +showOperation GLSL_SAbs = "SAbs" +showOperation GLSL_FSign = "FSign" +showOperation GLSL_SSign = "SSign" +showOperation GLSL_Floor = "Floor" +showOperation GLSL_Ceil = "Ceil" +showOperation GLSL_Fract = "Fract" +showOperation GLSL_Sin = "Sin" +showOperation GLSL_Cos = "Cos" +showOperation GLSL_Tan = "Tan" +showOperation GLSL_Asin = "Asin" +showOperation GLSL_Acos = "Acos" +showOperation GLSL_Atan = "Atan" +showOperation GLSL_Sinh = "Sinh" +showOperation GLSL_Cosh = "Cosh" +showOperation GLSL_Tanh = "Tanh" +showOperation GLSL_Asinh = "Asinh" +showOperation GLSL_Acosh = "Acosh" +showOperation GLSL_Atanh = "Atanh" +showOperation GLSL_Atan2 = "Atan2" +showOperation GLSL_Pow = "Pow" +showOperation GLSL_Exp = "Exp" +showOperation GLSL_Log = "Log" +showOperation GLSL_Sqrt = "Sqrt" +showOperation GLSL_InvSqrt = "InvSqrt" +showOperation GLSL_Determinant = "Determinant" +showOperation GLSL_MatrixInverse = "MatrixInverse" +showOperation GLSL_FMin = "FMin" +showOperation GLSL_UMin = "UMin" +showOperation GLSL_SMin = "SMin" +showOperation GLSL_FMax = "FMax" +showOperation GLSL_UMax = "UMax" +showOperation GLSL_SMax = "SMax" +showOperation GLSL_Cross = "Cross" +showOperation GLSL_Normalize = "Normalize" +-- OpenCL instructions +showOperation OpenCL_Acos = "Acos" +showOperation OpenCL_Acosh = "Acosh" +showOperation OpenCL_Asin = "Asin" +showOperation OpenCL_Asinh = "Asinh" +showOperation OpenCL_Atan = "Atan" +showOperation OpenCL_Atan2 = "Atan2" +showOperation OpenCL_Atanh = "Atanh" +showOperation OpenCL_Cbrt = "Cbrt" +showOperation OpenCL_Ceil = "Ceil" +showOperation OpenCL_Cos = "Cos" +showOperation OpenCL_Cosh = "Cosh" +showOperation OpenCL_Erfc = "Erfc" +showOperation OpenCL_Erf = "Erf" +showOperation OpenCL_Exp = "Exp" +showOperation OpenCL_Exp2 = "Exp2" +showOperation OpenCL_Exp10 = "Exp10" +showOperation OpenCL_Expm1 = "Expm1" +showOperation OpenCL_FAbs = "FAbs" +showOperation OpenCL_FDim = "FDim" +showOperation OpenCL_Floor = "Floor" +showOperation OpenCL_FMAdd = "FMAdd" +showOperation OpenCL_FMax = "FMax" +showOperation OpenCL_FMin = "FMin" +showOperation OpenCL_FMod = "FMod" +showOperation OpenCL_Fract = "Fract" +showOperation OpenCL_FRExp = "FRExp" +showOperation OpenCL_Hypot = "Hypot" +showOperation OpenCL_LogGamma = "LogGamma" +showOperation OpenCL_Log = "Log" +showOperation OpenCL_Log2 = "Log2" +showOperation OpenCL_Log10 = "Log10" +showOperation OpenCL_Log1P = "Log1P" +showOperation OpenCL_LogB = "LogB" +showOperation OpenCL_MAdd = "MAdd" +showOperation OpenCL_MaxMag = "MaxMag" +showOperation OpenCL_MinMag = "MinMag" +showOperation OpenCL_ModF = "ModF" +showOperation OpenCL_NaN = "NaN" +showOperation OpenCL_NextAfter = "NextAfter" +showOperation OpenCL_Pow = "Pow" +showOperation OpenCL_FRem = "FRem" +showOperation OpenCL_FRemQuot = "FRemQuot" +showOperation OpenCL_RoundEven = "RoundEven" +showOperation OpenCL_Round = "Round" +showOperation OpenCL_InvSqrt = "InvSqrt" +showOperation OpenCL_Sin = "Sin" +showOperation OpenCL_SinCos = "SinCos" +showOperation OpenCL_Sinh = "Sinh" +showOperation OpenCL_Sqrt = "Sqrt" +showOperation OpenCL_Tan = "Tan" +showOperation OpenCL_Tanh = "Tanh" +showOperation OpenCL_Gamma = "Gamma" +showOperation OpenCL_Trunc = "Trunc" +showOperation OpenCL_FSign = "FSign" +showOperation OpenCL_SAbs = "SAbs" +showOperation OpenCL_SAbsDiff = "SAbsDiff" +showOperation OpenCL_SMax = "SMax" +showOperation OpenCL_UMax = "UMax" +showOperation OpenCL_SMin = "SMin" +showOperation OpenCL_UMin = "UMin" +showOperation OpenCL_UAbs = "UAbs" +showOperation OpenCL_UAbsDiff = "UAbsDiff" +showOperation OpenCL_Cross = "Cross" +showOperation OpenCL_Normalize = "Normalize" +showOperation DebugPrintf = "DebugPrintf" +showOperation (Code i) = show i +showOperation (ExtCode _ i) = show i diff --git a/src/SPIRV/PrimOp.hs b/src/SPIRV/PrimOp.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/PrimOp.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| +Module: SPIRV.PrimOp + +This module categorises the raw primitive OpCodes from "SPIRV.Operation". + +This allows easier use of operations by generalising over certain aspects, +such as unifying the various arithmetic and logical operations. +For instance, instead of having to distinguish: + + * @UMin@, unsigned integer minimum, + * @SMin@, signed integer minimum, and + * @FMin@, floating point minimum, + +one can simply refer to the @Min@ operation defined in this module, +and the functions within this module will dispatch the correct primitive +operation depending on the types involved. + +Refer also to the module "FIR.Prim.Op", which ties these into the rest of the library. +-} + +module SPIRV.PrimOp + ( PrimOp(..) + , BoolPrimOp(..), EqPrimOp(..), OrdPrimOp(..) + , BitPrimOp(..) + , NumPrimOp(..), FloatPrimOp(..) + , VecPrimOp(..), MatPrimOp(..) + , ConvPrimOp(..) + , GeomPrimOp(..) + , SyncPrimOp(..) + , GroupPrimOp(..), GroupNumOp(..), GroupBitwiseOp(..), GroupLogicOp(..) + , RayPrimOp(..) + , opAndReturnType, op + ) where + +-- base +import Prelude + hiding ( Ordering(..) ) +import Control.Arrow + ( second ) +import Data.Word + ( Word32 ) + +-- fir +import SPIRV.Operation +import SPIRV.PrimTy + ( PrimTy(..) ) +import SPIRV.ScalarTy + ( ScalarTy(..), Signedness(..) ) +import SPIRV.Stage + ( Backend(Vulkan, OpenCL) ) + +------------------------------------------------------------------------------- +-- names of primitive operations + +data PrimOp where + BoolOp :: BoolPrimOp -> PrimOp + EqOp :: EqPrimOp -> PrimTy -> PrimOp + OrdOp :: OrdPrimOp -> ScalarTy -> PrimOp + BitOp :: BitPrimOp -> ScalarTy -> PrimOp + NumOp :: NumPrimOp -> ScalarTy -> PrimOp + FloatOp :: FloatPrimOp -> ScalarTy -> PrimOp + VecOp :: VecPrimOp -> Word32 -> PrimTy -> PrimOp + MatOp :: MatPrimOp -> Word32 -> Word32 -> ScalarTy -> PrimOp + ConvOp :: ConvPrimOp -> ScalarTy -> ScalarTy -> PrimOp + CastOp :: PrimTy -> PrimOp + GeomOp :: GeomPrimOp -> PrimOp + SyncOp :: SyncPrimOp -> PrimOp + GroupOp :: GroupPrimOp -> PrimOp + RayOp :: RayPrimOp -> PrimOp + deriving stock Show + +data BoolPrimOp + = BoolOr + | BoolAnd + | BoolNot + deriving stock Show + +data EqPrimOp + = Equal + | NotEqual + deriving stock Show + +data OrdPrimOp + = GT + | GTE + | LT + | LTE + | Min + | Max + deriving stock Show + +data BitPrimOp + = BitAnd + | BitOr + | BitXor + | BitNot + | ReverseBits + -- | Right shift: logical for unsigned integers, arithmetic for signed integers + -- (as 'Data.Bits.shiftR'). + | BitShiftRight + | BitShiftLeft + deriving stock Show + +data NumPrimOp + -- additive monoid + = Add + -- semiring + | Mul + -- additive group + | Sub + | Neg + -- signed + | Abs + | Sign + -- division ring + | Div + -- archimedean ordered group + | Mod + | Rem + | Quot + deriving stock Show + +data FloatPrimOp + = FSin + | FCos + | FTan + | FAsin + | FAcos + | FAtan + | FSinh + | FCosh + | FTanh + | FAsinh + | FAcosh + | FAtanh + | FAtan2 + | FPow + | FExp + | FLog + | FSqrt + | FInvSqrt + | FIsNaN + | FIsInf + deriving stock Show + +data VecPrimOp + = Vectorise PrimOp + | DotV + | VMulK + | CrossV + | NormaliseV + deriving stock Show + +data MatPrimOp + = MMulK + | MMulV + | VMulM + | MMulM + | Transp + | Det + | Inv + | Out + deriving stock Show + +data ConvPrimOp + = Convert + | CTruncate + | CRound + | CCeiling + | CFloor + deriving stock Show + +data GeomPrimOp + = EmitGeometryVertex + | EndGeometryPrimitive + deriving stock Show + +data SyncPrimOp + = ControlSync + | MemorySync + deriving stock Show + +data GroupPrimOp + = GroupNumOp GroupNumOp ScalarTy + | GroupBitwiseOp GroupBitwiseOp ScalarTy + | GroupLogicOp GroupLogicOp + deriving stock Show + +data GroupNumOp + = GroupAdd + | GroupMin + | GroupMax + | GroupMul + deriving stock Show + +data GroupBitwiseOp + = GroupBitwiseAnd + | GroupBitwiseOr + | GroupBitwiseXor + deriving stock Show + +data GroupLogicOp + = GroupLogicalAnd + | GroupLogicalOr + | GroupLogicalXor + deriving stock Show + +data RayPrimOp + = RT_ReportIntersection + | RT_IgnoreIntersection + | RT_TerminateRay + | RT_AccelerationStructureFromDeviceAddress + deriving stock Show + +backendOp :: Backend -> Operation -> Operation -> Operation +backendOp Vulkan o _ = o +backendOp OpenCL _ o = o + +opAndReturnType :: Backend -> PrimOp -> (Operation, PrimTy) +opAndReturnType _ (BoolOp boolOp) + = ( booleanOp boolOp + , Boolean + ) +opAndReturnType _ (EqOp eqOp s) + = ( equalityOp eqOp s + , Boolean + ) +opAndReturnType bk (OrdOp ordOp s) + = orderOp bk ordOp s +opAndReturnType _ (BitOp bitOp s) + = bitwiseOp bitOp s +opAndReturnType _ (CastOp s) + = castOp s +opAndReturnType bk (NumOp numOp s) + = second Scalar (numericOp bk numOp s) +opAndReturnType bk (FloatOp flOp s) + = floatingOp bk flOp s +opAndReturnType bk (VecOp vecOp n ty) + = vectorOp bk vecOp n ty +opAndReturnType bk (MatOp matOp n m s) + = matrixOp bk matOp n m s +opAndReturnType bk (ConvOp cOp s1 s2) + = second Scalar (convOp bk cOp s1 s2) +opAndReturnType _ (GeomOp gOp) + = geomOp gOp +opAndReturnType _ (SyncOp sOp) + = syncOp sOp +opAndReturnType bk (GroupOp gOp) + = groupOp bk gOp +opAndReturnType _ (RayOp rOp) + = rayOp rOp + +op :: Backend -> PrimOp -> Operation +op bkend = fst . opAndReturnType bkend + +booleanOp :: BoolPrimOp -> Operation +booleanOp BoolOr = LogicalOr +booleanOp BoolAnd = LogicalAnd +booleanOp BoolNot = LogicalNot + +equalityOp :: EqPrimOp -> PrimTy -> Operation +equalityOp Equal (Scalar (Floating _)) = FOrdEqual -- not reflexive! +equalityOp Equal (Scalar (Integer _ _)) = IEqual +equalityOp Equal Boolean = LogicalEqual +equalityOp NotEqual (Scalar (Floating _)) = FOrdNotEqual +equalityOp NotEqual (Scalar (Integer _ _)) = INotEqual +equalityOp NotEqual Boolean = LogicalNotEqual +equalityOp primOp ty = error $ "internal error: unsupported type " ++ show ty ++ " with equality operation " ++ show primOp + +orderOp :: Backend -> OrdPrimOp -> ScalarTy -> (Operation, PrimTy) +orderOp _ GT (Integer Unsigned _) = ( UGreaterThan , Boolean ) +orderOp _ GT (Integer Signed _) = ( SGreaterThan , Boolean ) +orderOp _ GT (Floating _) = ( FOrdGreaterThan , Boolean ) +orderOp _ GTE (Integer Unsigned _) = ( UGreaterThanEqual , Boolean ) +orderOp _ GTE (Integer Signed _) = ( SGreaterThanEqual , Boolean ) +orderOp _ GTE (Floating _) = ( FOrdGreaterThanEqual, Boolean ) +orderOp _ LT (Integer Unsigned _) = ( ULessThan , Boolean ) +orderOp _ LT (Integer Signed _) = ( SLessThan , Boolean ) +orderOp _ LT (Floating _) = ( FOrdLessThan , Boolean ) +orderOp _ LTE (Integer Unsigned _) = ( ULessThanEqual , Boolean ) +orderOp _ LTE (Integer Signed _) = ( SLessThanEqual , Boolean ) +orderOp _ LTE (Floating _) = ( FOrdLessThanEqual , Boolean ) +orderOp bk Min (Integer Unsigned w) = ( backendOp bk GLSL_UMin OpenCL_UMin , Scalar (Integer Unsigned w) ) +orderOp bk Min (Integer Signed w) = ( backendOp bk GLSL_SMin OpenCL_SMin , Scalar (Integer Signed w) ) +orderOp bk Min (Floating w) = ( backendOp bk GLSL_FMin OpenCL_FMin , Scalar (Floating w) ) +orderOp bk Max (Integer Unsigned w) = ( backendOp bk GLSL_UMax OpenCL_UMax , Scalar (Integer Unsigned w) ) +orderOp bk Max (Integer Signed w) = ( backendOp bk GLSL_SMax OpenCL_SMax , Scalar (Integer Signed w) ) +orderOp bk Max (Floating w) = ( backendOp bk GLSL_FMax OpenCL_FMax , Scalar (Floating w) ) + +bitwiseOp :: BitPrimOp -> ScalarTy -> (Operation, PrimTy) +bitwiseOp BitAnd s = (BitwiseAnd, Scalar s) +bitwiseOp BitOr s = (BitwiseOr , Scalar s) +bitwiseOp BitXor s = (BitwiseXor, Scalar s) +bitwiseOp BitNot s = (Not , Scalar s) +bitwiseOp ReverseBits s = (BitReverse, Scalar s) +bitwiseOp BitShiftRight s@(Integer Unsigned _) = (ShiftRightLogical , Scalar s) +bitwiseOp BitShiftRight s@(Integer Signed _) = (ShiftRightArithmetic, Scalar s) +bitwiseOp BitShiftRight s@(Floating _) = error ( "bitwiseOp: cannot shift a value of type " ++ show s ) +bitwiseOp BitShiftLeft s = (ShiftLeftLogical, Scalar s) + +castOp :: PrimTy -> (Operation, PrimTy) +castOp s = (BitCast, s) + +numericOp :: Backend -> NumPrimOp -> ScalarTy -> (Operation, ScalarTy) +-- additive monoid +numericOp _ Add (Floating w) = ( FAdd , Floating w ) +numericOp _ Add (Integer s w) = ( IAdd , Integer s w ) +-- semiring +numericOp _ Mul (Floating w) = ( FMul , Floating w ) +numericOp _ Mul (Integer s w) = ( IMul , Integer s w ) +-- additive group +numericOp _ Sub (Floating w) = ( FSub , Floating w ) +numericOp _ Sub (Integer s w) = ( ISub , Integer s w ) +numericOp _ Neg (Floating w) = ( FNegate, Floating w ) +numericOp _ Neg (Integer Signed w) = ( SNegate, Integer Signed w ) +numericOp _ Neg (Integer Unsigned _) = error "internal error: 'negate' called on unsigned type" +-- signed +numericOp bk Abs (Floating w) = ( backendOp bk GLSL_FAbs OpenCL_FAbs , Floating w ) +numericOp bk Abs (Integer Signed w) = ( backendOp bk GLSL_SAbs OpenCL_SAbs , Integer Signed w ) +numericOp _ Abs (Integer Unsigned _) = error "internal error: 'abs' called on unsigned type" +numericOp bk Sign (Floating w) = ( backendOp bk GLSL_FSign OpenCL_FSign, Floating w ) +numericOp bk Sign (Integer Signed w) + | OpenCL <- bk = error "TODO: OpenCL backend does not support 'signum' operation on integer types" + | otherwise = ( GLSL_SSign , Integer Signed w ) +numericOp _ Sign (Integer Unsigned _) = error "internal error: 'signum' called on unsigned type" +-- division ring +numericOp _ Div (Floating w) = ( FDiv , Floating w ) +numericOp _ Div (Integer _ _) = error "internal error: Div used with integral type" +-- archimedean ordered group +numericOp _ Mod (Floating w) = ( FMod , Floating w ) +numericOp _ Mod (Integer Signed w) = ( SMod , Integer Signed w ) +numericOp _ Mod (Integer Unsigned w) = ( UMod , Integer Unsigned w ) +numericOp _ Rem (Floating w) = ( FRem , Floating w ) +numericOp _ Rem (Integer Signed w) = ( SRem , Integer Signed w ) +numericOp _ Rem (Integer Unsigned w) = ( UMod , Integer Unsigned w ) -- URem pointless for unsigned type +numericOp _ Quot (Integer Signed w) = ( SDiv , Integer Signed w ) +numericOp _ Quot (Integer Unsigned w) = ( UDiv , Integer Unsigned w ) +numericOp _ Quot (Floating _) = error "internal error: Quot used with floating-point type" + +floatingOp :: Backend -> FloatPrimOp -> ScalarTy -> (Operation, PrimTy) +floatingOp bk FSin s = ( backendOp bk GLSL_Sin OpenCL_Sin , Scalar s ) +floatingOp bk FCos s = ( backendOp bk GLSL_Cos OpenCL_Cos , Scalar s ) +floatingOp bk FTan s = ( backendOp bk GLSL_Tan OpenCL_Tan , Scalar s ) +floatingOp bk FAsin s = ( backendOp bk GLSL_Asin OpenCL_Asin , Scalar s ) +floatingOp bk FAcos s = ( backendOp bk GLSL_Acos OpenCL_Acos , Scalar s ) +floatingOp bk FAtan s = ( backendOp bk GLSL_Atan OpenCL_Atan , Scalar s ) +floatingOp bk FSinh s = ( backendOp bk GLSL_Sinh OpenCL_Sinh , Scalar s ) +floatingOp bk FCosh s = ( backendOp bk GLSL_Cosh OpenCL_Cosh , Scalar s ) +floatingOp bk FTanh s = ( backendOp bk GLSL_Tanh OpenCL_Tanh , Scalar s ) +floatingOp bk FAsinh s = ( backendOp bk GLSL_Asinh OpenCL_Asinh , Scalar s ) +floatingOp bk FAcosh s = ( backendOp bk GLSL_Acosh OpenCL_Acosh , Scalar s ) +floatingOp bk FAtanh s = ( backendOp bk GLSL_Atanh OpenCL_Atanh , Scalar s ) +floatingOp bk FAtan2 s = ( backendOp bk GLSL_Atan2 OpenCL_Atan2 , Scalar s ) +floatingOp bk FPow s = ( backendOp bk GLSL_Pow OpenCL_Pow , Scalar s ) +floatingOp bk FExp s = ( backendOp bk GLSL_Exp OpenCL_Exp , Scalar s ) +floatingOp bk FLog s = ( backendOp bk GLSL_Log OpenCL_Log , Scalar s ) +floatingOp bk FSqrt s = ( backendOp bk GLSL_Sqrt OpenCL_Sqrt , Scalar s ) +floatingOp bk FInvSqrt s = ( backendOp bk GLSL_InvSqrt OpenCL_InvSqrt , Scalar s ) +floatingOp _ FIsNaN _ = ( IsNan, Boolean ) +floatingOp _ FIsInf _ = ( IsInf, Boolean ) + +vectorOp :: Backend -> VecPrimOp -> Word32 -> PrimTy -> (Operation, PrimTy) +vectorOp bk (Vectorise prim) n ty = ( op bk prim, Vector n ty ) +vectorOp _ DotV _ (Scalar (Floating w)) = ( Dot, Scalar (Floating w) ) +vectorOp _ DotV _ _ = error "internal error: dot product: vector elements must be of floating-point type." +vectorOp _ VMulK n (Scalar (Floating w)) = ( VectorTimesScalar, Vector n (Scalar (Floating w)) ) +vectorOp _ VMulK _ _ = error "internal error: scalar multiplication: vector elements must be of floating-point type." +vectorOp bk CrossV n (Scalar (Floating w)) = ( backendOp bk GLSL_Cross OpenCL_Cross, Vector n (Scalar (Floating w)) ) +vectorOp _ CrossV _ _ = error "internal error: cross product: vector elements must be of floating-point type." +vectorOp bk NormaliseV n (Scalar (Floating w)) = ( backendOp bk GLSL_Normalize OpenCL_Normalize, Vector n (Scalar (Floating w)) ) +vectorOp _ NormaliseV _ _ = error "internal error: normalise: vector elements must be of floating-point type." + +matrixOp :: Backend -> MatPrimOp -> Word32 -> Word32 -> ScalarTy -> (Operation, PrimTy) +matrixOp _ MMulK n m s = ( MatrixTimesScalar, Matrix n m s ) +matrixOp _ MMulV n _ s = ( MatrixTimesVector, Vector n (Scalar s) ) +matrixOp _ VMulM n _ s = ( VectorTimesMatrix, Vector n (Scalar s) ) +matrixOp _ MMulM n m s = ( MatrixTimesMatrix, Matrix n m s ) +matrixOp _ Transp n m s = ( Transpose , Matrix n m s ) +matrixOp bk Det _ _ s + | Vulkan <- bk = ( GLSL_Determinant , Scalar s ) + | otherwise = error "todo: determinant not implemented in OpenCL backend" +matrixOp bk Inv n m s + | Vulkan <- bk = ( GLSL_MatrixInverse , Matrix n m s ) + | otherwise = error "todo: matrix inverse not implemented in OpenCL backend" +matrixOp _ Out n m s = ( OuterProduct , Matrix n m s ) + +convOp :: Backend -> ConvPrimOp -> ScalarTy -> ScalarTy -> (Operation, ScalarTy) +convOp _ Convert (Integer Signed _) (Floating w) = ( ConvertSToF, Floating w ) +convOp _ Convert (Integer Unsigned _) (Floating w) = ( ConvertUToF, Floating w ) +convOp _ Convert (Floating _) (Integer Signed w) = ( ConvertFToS, Integer Signed w ) +convOp _ Convert (Floating _) (Integer Unsigned w) = ( ConvertFToU, Integer Unsigned w ) +convOp bk Convert (Integer Unsigned v) (Integer Signed w) + | OpenCL <- bk = ( SatConvertUToS, Integer Signed w ) + | v == w = ( BitCast, Integer Signed w ) + | otherwise = error "internal error: unsupported conversion between integer types of different width and sign" +convOp bk Convert (Integer Signed v) (Integer Unsigned w) + | OpenCL <- bk = ( SatConvertSToU, Integer Unsigned w ) + | v == w = ( BitCast , Integer Unsigned w ) + | otherwise = error "internal error: unsupported conversion between integer types of different width and sign" +convOp _ Convert (Floating v) (Floating w) + | v /= w = ( FConvert, Floating w) +convOp _ Convert (Integer Signed v) (Integer Signed w) + | v /= w = ( SConvert, Integer Signed w) +convOp _ Convert (Integer Unsigned v) (Integer Unsigned w) + | v /= w = ( UConvert, Integer Unsigned w) +convOp _ CTruncate (Floating _) (Integer Signed w) = ( ConvertFToS, Integer Signed w ) +convOp _ CTruncate (Floating _) (Integer Unsigned w) = ( ConvertFToU, Integer Unsigned w ) +convOp bk CTruncate (Floating v) (Floating w) + | v == w = ( backendOp bk GLSL_Trunc OpenCL_Trunc, Floating w ) + | otherwise = error "internal error: unsupported truncation between floating point types of different widths" +convOp bk CRound (Floating v) (Floating w) + | v == w = ( backendOp bk GLSL_Round OpenCL_Round, Floating w ) + | otherwise = error "internal error: unsupported rounding between floating point types of different widths" +convOp bk CFloor (Floating v) (Floating w) + | v == w = ( backendOp bk GLSL_Floor OpenCL_Floor, Floating w ) + | otherwise = error "internal error: unsupported floor operation between floating point types of different widths" +convOp bk CCeiling (Floating v) (Floating w) + | v == w = ( backendOp bk GLSL_Ceil OpenCL_Ceil, Floating w ) + | otherwise = error "internal error: unsupported ceiling operation between floating point types of different widths" +convOp _ cOp a b + = error $ "internal error: unsupported operation " ++ show cOp ++ " from type " ++ show a ++ " to type " ++ show b + +geomOp :: GeomPrimOp -> (Operation, PrimTy) +geomOp EmitGeometryVertex = ( EmitVertex , Unit ) +geomOp EndGeometryPrimitive = ( EndPrimitive, Unit ) + +syncOp :: SyncPrimOp -> (Operation, PrimTy) +syncOp ControlSync = ( ControlBarrier, Unit ) +syncOp MemorySync = ( MemoryBarrier , Unit ) + +groupOp :: Backend -> GroupPrimOp -> (Operation, PrimTy) +groupOp bk (GroupNumOp gpOp s) = second Scalar $ groupNumOp bk gpOp s +groupOp OpenCL gpOp = error $ "internal error: OpenCL backend does not support group operation " ++ show gpOp +groupOp _ (GroupBitwiseOp gpOp s) = (groupBitwiseOp gpOp, Scalar s) +groupOp _ (GroupLogicOp gpOp) = (groupLogicOp gpOp, Boolean) + +groupNumOp :: Backend -> GroupNumOp -> ScalarTy -> (Operation, ScalarTy) +groupNumOp OpenCL GroupAdd (Floating w) = ( GroupFAdd, Floating w ) +groupNumOp OpenCL GroupAdd (Integer s w) = ( GroupIAdd, Integer s w ) +groupNumOp OpenCL GroupMax (Floating w) = ( GroupFMax, Floating w ) +groupNumOp OpenCL GroupMax (Integer Signed w) = ( GroupSMax, Integer Signed w ) +groupNumOp OpenCL GroupMax (Integer Unsigned w) = ( GroupUMax, Integer Unsigned w ) +groupNumOp OpenCL GroupMin (Floating w) = ( GroupFMin, Floating w ) +groupNumOp OpenCL GroupMin (Integer Signed w) = ( GroupSMin, Integer Signed w ) +groupNumOp OpenCL GroupMin (Integer Unsigned w) = ( GroupUMin, Integer Unsigned w ) +groupNumOp Vulkan GroupAdd (Floating w) = ( GroupNonUniformFAdd, Floating w ) +groupNumOp Vulkan GroupAdd (Integer s w) = ( GroupNonUniformIAdd, Integer s w ) +groupNumOp Vulkan GroupMul (Floating w) = ( GroupNonUniformFMul, Floating w ) +groupNumOp Vulkan GroupMul (Integer s w) = ( GroupNonUniformIMul, Integer s w ) +groupNumOp Vulkan GroupMax (Floating w) = ( GroupNonUniformFMax, Floating w ) +groupNumOp Vulkan GroupMax (Integer Signed w) = ( GroupNonUniformSMax, Integer Signed w ) +groupNumOp Vulkan GroupMax (Integer Unsigned w) = ( GroupNonUniformUMax, Integer Unsigned w ) +groupNumOp Vulkan GroupMin (Floating w) = ( GroupNonUniformFMin, Floating w ) +groupNumOp Vulkan GroupMin (Integer Signed w) = ( GroupNonUniformSMin, Integer Signed w ) +groupNumOp Vulkan GroupMin (Integer Unsigned w) = ( GroupNonUniformUMin, Integer Unsigned w ) +groupNumOp OpenCL GroupMul _ = + error "internal error: OpenCL backend does not support GroupMul operation" + +groupBitwiseOp :: GroupBitwiseOp -> Operation +groupBitwiseOp GroupBitwiseAnd = GroupNonUniformBitwiseAnd +groupBitwiseOp GroupBitwiseOr = GroupNonUniformBitwiseOr +groupBitwiseOp GroupBitwiseXor = GroupNonUniformBitwiseXor + +groupLogicOp :: GroupLogicOp -> Operation +groupLogicOp GroupLogicalAnd = GroupNonUniformLogicalAnd +groupLogicOp GroupLogicalOr = GroupNonUniformLogicalOr +groupLogicOp GroupLogicalXor = GroupNonUniformLogicalXor + +rayOp :: RayPrimOp -> (Operation, PrimTy) +rayOp RT_ReportIntersection = ( ReportIntersection, Boolean ) +rayOp RT_IgnoreIntersection = ( IgnoreIntersection, Unit ) +rayOp RT_TerminateRay = ( TerminateRay, Unit ) +rayOp RT_AccelerationStructureFromDeviceAddress = ( ConvertUToAccelerationStructure, AccelerationStructure ) diff --git a/src/SPIRV/PrimTy.hs b/src/SPIRV/PrimTy.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/PrimTy.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} + +{-| +Module: SPIRV.PrimTy + +This module enumerates the types that exist within the SPIR-V type system. + +These are logical types: they don't include any memory layout information. +The layout of a type in memory is specified separately, by a 'Layout'. + +See the SPIR-V specification, §3.22.6 __Type-Declaration instructions__. +-} + +module SPIRV.PrimTy + ( PrimTy(..) + , PointerTy(..) + , componentLayout + , tyOp + , scalars + ) where + +-- base +import Data.Word + ( Word32 ) +import Prelude + hiding (Integer, Floating) + +-- text-short +import Data.Text.Short + ( ShortText ) + +-- fir +import SPIRV.Image + ( Image(texelComponent) ) +import SPIRV.Layout + ( Layout(blockKind) ) +import SPIRV.Operation + hiding ( Function, Image, SampledImage ) +import SPIRV.ScalarTy + ( ScalarTy(Integer, Floating) ) +import SPIRV.Storage + ( StorageClass ) + +-------------------------------------------------- +-- SPIR-V types + +data PrimTy where + Unit :: PrimTy -- known as Void in the SPIR-V specification + Boolean :: PrimTy + Scalar :: ScalarTy -> PrimTy + Vector :: + { size :: Word32 + , eltTy :: PrimTy + } -> PrimTy + Matrix :: + { rows :: Word32 + , cols :: Word32 + , entryTy :: ScalarTy + } -> PrimTy + Array :: + { size :: Word32 + , eltTy :: PrimTy + } -> PrimTy + RuntimeArray :: + { eltTy :: PrimTy + } -> PrimTy + Struct :: + { eltTys :: [ ( Maybe ShortText, PrimTy ) ] + -- ^ the (optional) field names are only used to annotate the source code + } -> PrimTy + Pointer :: PointerTy -> PrimTy + Function :: + { argumentTypes :: [PrimTy] + , resultType :: PrimTy + } -> PrimTy + Image :: Image -> PrimTy + Sampler :: PrimTy -- opaque + SampledImage :: Image -> PrimTy + AccelerationStructure :: PrimTy -- opaque + RayQuery :: PrimTy -- opaque + deriving stock ( Show, Eq, Ord ) + +-- | A pointer type, to a type laid out in memory in the given way. +data PointerTy + = PointerTy + { pointerStorage :: StorageClass + , pointerLayout :: Layout + , pointee :: PrimTy + } + deriving stock ( Show, Eq, Ord ) + +-- | The layout of the components of a composite type with the given layout. +-- +-- The elements of an array of interface blocks are interface blocks, +-- but the members of an interface block are not. +componentLayout :: PrimTy -> Layout -> Layout +componentLayout Array {} lay = lay +componentLayout RuntimeArray {} lay = lay +componentLayout _ lay = lay { blockKind = Nothing } + +tyOp :: PrimTy -> Operation +tyOp Unit = TypeVoid +tyOp Boolean = TypeBool +tyOp (Scalar Integer {}) = TypeInt +tyOp (Scalar Floating {}) = TypeFloat +tyOp (Vector _ (Vector _ _)) = TypeMatrix + -- SPIR-V doesn't have vectors of vectors, so declare them as matrices instead. + -- This is a bit of a workaround for issue #95. +tyOp Vector {} = TypeVector +tyOp Matrix {} = TypeMatrix +tyOp Array {} = TypeArray +tyOp RuntimeArray {} = TypeRuntimeArray +tyOp Struct {} = TypeStruct +tyOp Function {} = TypeFunction +tyOp Pointer {} = TypePointer +tyOp Image {} = TypeImage +tyOp Sampler = TypeSampler +tyOp SampledImage {} = TypeSampledImage +tyOp AccelerationStructure = TypeAccelerationStructure +tyOp RayQuery = TypeRayQuery + +scalars :: PrimTy -> [ ScalarTy ] +scalars Unit = [ ] +scalars Boolean = [ ] +scalars (Scalar s) = [ s ] +scalars (Vector _ a) = scalars a +scalars (Matrix _ _ a) = [ a ] +scalars (Array { eltTy }) = scalars eltTy +scalars (RuntimeArray { eltTy }) = scalars eltTy +scalars (Struct { eltTys }) = scalars . snd =<< eltTys +scalars (Pointer ptrTy) = scalars ( pointee ptrTy ) +scalars (Function as b) = scalars b ++ ( scalars =<< as ) +scalars (Image img) = [ texelComponent img ] +scalars Sampler = [ ] +scalars (SampledImage img) = [ texelComponent img ] +scalars AccelerationStructure = [] +scalars RayQuery = [] diff --git a/src/SPIRV/Requirements.hs b/src/SPIRV/Requirements.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Requirements.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ViewPatterns #-} + +{-| +Module: SPIRV.Requrements + +Functions computing capability/extension requirements +for various circumstances. + +-} + +module SPIRV.Requirements where + +-- base +import Data.Bits + ( Bits(testBit) ) +import Data.Word + ( Word32 ) + +-- containers +import Data.Set + ( Set ) +import qualified Data.Set as Set + ( insert, unions ) + +-- fir +import SPIRV.Capability +import SPIRV.Extension +import qualified SPIRV.Image as Image +import SPIRV.Operation + hiding ( Capability ) +import SPIRV.PrimOp + ( PrimOp(..), VecPrimOp(..), GroupPrimOp(..), BitPrimOp(ReverseBits) + , op + ) +import SPIRV.PrimTy + ( PrimTy, scalars ) +import qualified SPIRV.PrimTy as PrimTy +import SPIRV.ScalarTy + ( ScalarTy, Width(..) ) +import qualified SPIRV.ScalarTy as ScalarTy +import SPIRV.Stage + ( ExecutionModel(Stage), Stage(..), Shader, Backend(..) ) +import qualified SPIRV.Stage as Stage + ( ExecutionModel(..), Shader(..) ) +import SPIRV.Version + ( Version(..) ) + +-------------------------------------------------------------------------- +-- primitive operations + +primOpCapabilities :: Backend -> PrimOp -> Set Capability +primOpCapabilities bk ( op bk -> SatConvertSToU ) = [ ComputeKernel ] +primOpCapabilities bk ( op bk -> SatConvertUToS ) = [ ComputeKernel ] +primOpCapabilities _ ( MatOp {} ) = [ Matrix ] +primOpCapabilities _ ( RayOp {} ) = [ RayTracingKHR ] +primOpCapabilities bk ( BitOp ReverseBits _ ) = + case bk of + SPIRV.Stage.Vulkan -> [ ] -- (requires the Shader capability) + SPIRV.Stage.OpenCL -> [ BitInstructions ] +primOpCapabilities bk ( GroupOp gpOp ) = groupOpCapabilities bk gpOp +primOpCapabilities bk ( VecOp ( Vectorise primop ) _ _ ) = primOpCapabilities bk primop +primOpCapabilities _ _ = [ ] + +groupOpCapabilities :: Backend -> GroupPrimOp -> Set Capability +groupOpCapabilities bk _ = + case bk of + SPIRV.Stage.OpenCL -> [ Groups ] + SPIRV.Stage.Vulkan -> [ GroupNonUniformArithmetic ] + +primOpExtensions :: Backend -> PrimOp -> Set Extension +primOpExtensions SPIRV.Stage.OpenCL ( BitOp ReverseBits _ ) = [ SPV_KHR_bit_instructions ] +primOpExtensions bk ( VecOp ( Vectorise primop ) _ _ ) = primOpExtensions bk primop +primOpExtensions _ _ = [ ] + +-- | Why the backend doesn't support a primitive operation (regardless of capabilities, +-- extensions and SPIR-V version), if it doesn't. +primOpUnsupported :: Backend -> PrimOp -> Maybe String +primOpUnsupported SPIRV.Stage.Vulkan ( BitOp ReverseBits s ) + | ScalarTy.scalarWidth s /= W32 + = Just "Vulkan only supports OpBitReverse on 32-bit integers" +primOpUnsupported bk ( VecOp ( Vectorise primop ) _ _ ) = primOpUnsupported bk primop +primOpUnsupported _ _ = Nothing + +primOpMinVersion :: Backend -> PrimOp -> Version +primOpMinVersion SPIRV.Stage.Vulkan ( GroupOp {} ) = Version 1 3 +primOpMinVersion _ _ = Version 1 0 + +-------------------------------------------------------------------------- +-- types + +scalarCapabilities :: ScalarTy -> Set Capability +scalarCapabilities (ScalarTy.Integer _ W8 ) = [ Int8 ] +scalarCapabilities (ScalarTy.Integer _ W16) = [ Int16 ] +scalarCapabilities (ScalarTy.Integer _ W64) = [ Int64 ] +scalarCapabilities (ScalarTy.Integer _ _ ) = [ ] +scalarCapabilities (ScalarTy.Floating W16) = [ Float16 ] +scalarCapabilities (ScalarTy.Floating W64) = [ Float64 ] +scalarCapabilities (ScalarTy.Floating _ ) = [ ] + +primTyCapabilities :: PrimTy -> Set Capability +primTyCapabilities ( PrimTy.Matrix _ _ ty ) + = Set.insert Matrix $ scalarCapabilities ty +primTyCapabilities ( PrimTy.Vector n ty ) + | n > 4 = Set.insert Vector16 $ primTyCapabilities ty + | otherwise = primTyCapabilities ty +primTyCapabilities ( PrimTy.Image img ) + = imageCapabilities img <> scalarCapabilities ( Image.texelComponent img ) +primTyCapabilities ( PrimTy.SampledImage img ) + = imageCapabilities img <> scalarCapabilities ( Image.texelComponent img ) +primTyCapabilities ty + = Set.unions ( map scalarCapabilities ( PrimTy.scalars ty) ) + +-- types when present in an interface +globalCapabilities :: PrimTy -> Set Capability +globalCapabilities = primTyCapabilities + +globalScalarExtensions :: ScalarTy -> Set Extension +globalScalarExtensions (ScalarTy.Integer _ W8 ) = [ SPV_KHR_8bit_storage ] +globalScalarExtensions (ScalarTy.Integer _ W16) = [ SPV_KHR_16bit_storage ] +globalScalarExtensions (ScalarTy.Integer _ _ ) = [ ] +globalScalarExtensions (ScalarTy.Floating W16) = [ SPV_KHR_16bit_storage ] +globalScalarExtensions (ScalarTy.Floating _ ) = [ ] + +globalExtensions :: PrimTy -> Set Extension +globalExtensions ty = Set.unions ( map globalScalarExtensions ( scalars ty ) ) + +-------------------------------------------------------------------------- +-- stages / execution models + +shaderCapabilities :: Shader -> Set Capability +shaderCapabilities Stage.VertexShader = [ Shader ] +shaderCapabilities Stage.TessellationControlShader = [ Tessellation ] --- | +shaderCapabilities Stage.TessellationEvaluationShader = [ Tessellation ] --- |-- shader capability implied +shaderCapabilities Stage.GeometryShader = [ Geometry ] --- | +shaderCapabilities Stage.FragmentShader = [ Shader ] +shaderCapabilities Stage.ComputeShader = [ Shader ] + +stageCapabilities :: Stage -> Set Capability +stageCapabilities (ShaderStage s) = shaderCapabilities s +stageCapabilities (MeshStage _) = [ MeshShadingNV ] +stageCapabilities (RayStage _) = [ RayTracingKHR ] + +executionModelCapabilities :: ExecutionModel -> Set Capability +executionModelCapabilities (Stage s) = stageCapabilities s +executionModelCapabilities Stage.Kernel = [ ComputeKernel, Addresses ] + +stageExtensions :: Stage -> Set Extension +stageExtensions (ShaderStage _) = [ ] +stageExtensions (MeshStage _) = [ SPV_NV_mesh_shader ] +stageExtensions (RayStage _) = [ SPV_KHR_ray_tracing ] + +executionModelExtensions :: ExecutionModel -> Set Extension +executionModelExtensions (Stage s) = stageExtensions s +executionModelExtensions Stage.Kernel = [ ] + +-------------------------------------------------------------------------- +-- images, image formats, image properties + +formatCapabilities :: Image.ImageFormat Word32 -> Set Capability +formatCapabilities format + = case Image.requiredFormatUsage format of + Just Image.Storage -> [ Shader, StorageImageExtendedFormats ] + _ -> [ Shader ] + +-- | Capabilities required to read from an image of the given dimensionality +-- and format using @OpImageRead@. +unknownFormatReadCapabilities :: Image.Dimensionality -> Maybe (Image.ImageFormat Word32) -> Set Capability +unknownFormatReadCapabilities Image.SubpassData _ = [ ] +unknownFormatReadCapabilities _ Nothing = [ StorageImageReadWithoutFormat ] +unknownFormatReadCapabilities _ _ = [ ] + +-- | Capabilities required to write to an image of the given format +-- using @OpImageWrite@. +unknownFormatWriteCapabilities :: Maybe (Image.ImageFormat Word32) -> Set Capability +unknownFormatWriteCapabilities Nothing = [ StorageImageWriteWithoutFormat ] +unknownFormatWriteCapabilities _ = [ ] + +-- | Capabilities required to declare an image type. +imageCapabilities :: Image.Image -> Set Capability +imageCapabilities img + = foldMap formatCapabilities ( Image.imageFormat img ) + <> dimCapabilities ( Image.imageUsage img ) ( Image.dimensionality img ) ( Image.arrayness img ) + <> msCapabilities ( Image.imageUsage img ) ( Image.arrayness img ) ( Image.multiSampling img ) + +dimCapabilities :: Maybe Image.ImageUsage -> Image.Dimensionality -> Image.Arrayness -> Set Capability +dimCapabilities _ Image.SubpassData _ = [ Shader, InputAttachment ] +dimCapabilities (Just Image.Storage) Image.Rect _ = [ Shader, SampledRect, ImageRect ] +dimCapabilities _ Image.Rect _ = [ Shader, SampledRect ] +dimCapabilities (Just Image.Storage) Image.OneD _ = [ Sampled1D, Image1D ] +dimCapabilities _ Image.OneD _ = [ Sampled1D ] +dimCapabilities (Just Image.Storage) Image.Cube Image.Arrayed = [ SampledCubeArray, ImageCubeArray ] +dimCapabilities _ Image.Cube Image.Arrayed = [ SampledCubeArray ] +dimCapabilities (Just Image.Storage) Image.Buffer _ = [ SampledBuffer, ImageBuffer ] +dimCapabilities _ Image.Buffer _ = [ SampledBuffer ] +dimCapabilities _ _ _ = [ ] + +msCapabilities :: Maybe Image.ImageUsage -> Image.Arrayness -> Image.MultiSampling -> Set Capability +msCapabilities (Just Image.Storage) Image.Arrayed Image.MultiSampled = [ StorageImageMultisample, ImageMSArray ] +msCapabilities (Just Image.Storage) Image.NonArrayed Image.MultiSampled = [ StorageImageMultisample ] +msCapabilities _ _ _ = [ ] + +-- lod capability from image operand bitmask +-- (note that the bitmask is shifted up one byte from what SPIR-V uses) +lodCapabilities :: Backend -> Word32 -> Set Capability +lodCapabilities bk bm + -- uses the LOD operand + | bm `testBit` 9 + && bk == SPIRV.Stage.OpenCL + = [ ImageBasic, ImageMipmap ] + -- uses the MinLOD opeand + | bm `testBit` 15 + = [ MinLod ] + | otherwise + = [ ] + +-- whether the ImageGatherExtended capability is required +gatherCapabilities :: Word32 -> Set Capability +gatherCapabilities bm + | bm `testBit` 12 -- Offset operand + || bm `testBit` 13 -- ConstOffsets operand + = [ ImageGatherExtended ] + | otherwise + = [ ] diff --git a/src/SPIRV/ScalarTy.hs b/src/SPIRV/ScalarTy.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/ScalarTy.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module: SPIRV.ScalarTy + +This module enumerates the scalar types that exist within the SPIR-V type system: + + * unsigned integers, + * signed integers, and + * floating point numbers. + +-} + +module SPIRV.ScalarTy + ( Width(..), width, WidthToNat + , Signedness(..), signedness + , ScalarTy(..), scalarWidth, ScalarWidth + ) where + +-- base +import Data.Word + ( Word32 ) +import GHC.TypeNats + ( Nat ) +import Prelude + hiding ( Integer, Floating ) + +-- fir +import Data.Type.Known + ( Demotable(Demote), Known(known) ) + +-------------------------------------------------- +-- SPIR-V scalar types + +data Width + = W8 + | W16 + | W32 + | W64 + deriving stock ( Show, Eq, Ord, Enum, Bounded ) + +width :: Width -> Word32 +width W8 = 8 +width W16 = 16 +width W32 = 32 +width W64 = 64 + +type family WidthToNat (width :: Width) :: Nat where + WidthToNat W8 = 8 + WidthToNat W16 = 16 + WidthToNat W32 = 32 + WidthToNat W64 = 64 + +data Signedness + = Unsigned + | Signed + deriving stock ( Show, Eq, Ord, Enum, Bounded ) + +instance Demotable Signedness where + type Demote Signedness = Signedness +instance Known Signedness Unsigned where + known = Unsigned +instance Known Signedness Signed where + known = Signed + +signedness :: Signedness -> Word32 +signedness Unsigned = 0 +signedness Signed = 1 + +data ScalarTy where + Integer :: Signedness -> Width -> ScalarTy + Floating :: Width -> ScalarTy + deriving stock ( Show, Eq, Ord ) + +scalarWidth :: ScalarTy -> Width +scalarWidth (Integer _ w) = w +scalarWidth (Floating w) = w + +type family ScalarWidth (sTy :: ScalarTy) :: Width where + ScalarWidth (Integer _ w) = w + ScalarWidth (Floating w) = w diff --git a/src/SPIRV/Stage.hs b/src/SPIRV/Stage.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Stage.hs @@ -0,0 +1,510 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: SPIRV.Stage + +This module enumerates the SPIR-V execution models / shader stages. + +These are used both at the type-level and at the value-level. + +See the SPIR-V specification, §3.3 __Execution Model__. + + +This module also keeps track of certain execution modes that need to be known +at the type-level to perform certain type-level checks for custom error messages, +e.g. which kind of tessellation is happening (triangles, quads, isolines). +This information is eventually computed using user "SPIRV.Decoration.Decoration"s, +but it proved useful to separate these decorations out. + +-} + +module SPIRV.Stage where + +-- base +import Data.Kind + ( Type ) +import Data.Word + ( Word32 ) +import GHC.TypeLits + ( Symbol, AppendSymbol ) +import GHC.TypeNats + ( Nat, KnownNat, CmpNat ) + +-- fir +import Data.Binary.Class.Put + ( Put(..), PutWord32Enum(..) ) +import Data.Type.Known + ( Demotable(Demote), Known(known), knownValue ) +import Data.Type.POrd + ( POrd(Compare) ) + +------------------------------------------------------- +-- execution models / stages + +data ExecutionModel + = Stage Stage + | Kernel -- OpenCL compute kernel + deriving stock ( Show, Eq, Ord ) + +data Stage + = ShaderStage Shader + | MeshStage MeshShader + | RayStage RayShader + deriving stock ( Show, Eq, Ord ) + +data Shader + = VertexShader + | TessellationControlShader + | TessellationEvaluationShader + | GeometryShader + | FragmentShader + | ComputeShader -- GLCompute in SPIR-V + deriving stock ( Show, Eq, Ord, Enum, Bounded ) + deriving Put via (PutWord32Enum Shader) + +data MeshShader + = TaskShader + | MeshShader + deriving stock ( Show, Eq, Ord, Enum, Bounded ) + +instance Put MeshShader where + put = put @Word32 . (+5267) . fromIntegral . fromEnum + wordCount _ = 1 + +data RayShader + = RayGenerationShader + | IntersectionShader + | AnyHitShader + | ClosestHitShader + | MissShader + | CallableShader + deriving stock ( Show, Eq, Ord, Enum, Bounded ) + +instance Put RayShader where + put = put @Word32 . (+5313) . fromIntegral . fromEnum + wordCount _ = 1 + +instance Put Stage where + put (ShaderStage s) = put s + put (MeshStage s) = put s + put (RayStage s) = put s + wordCount _ = 1 + +instance Put ExecutionModel where + put (Stage s) = put s + put Kernel = put @Word32 6 + wordCount _ = 1 + +stageID :: Stage -> Word32 +stageID (ShaderStage s) = fromIntegral ( fromEnum s ) +stageID (MeshStage s) = fromIntegral ( fromEnum s + 5267 ) +stageID (RayStage s) = fromIntegral ( fromEnum s + 5313 ) + +executionModelID :: ExecutionModel -> Word32 +executionModelID (Stage s) = stageID s +executionModelID Kernel = 6 + + +type Vertex = 'Stage ('ShaderStage 'VertexShader) +type TessellationControl = 'Stage ('ShaderStage 'TessellationControlShader) +type TessellationEvaluation = 'Stage ('ShaderStage 'TessellationEvaluationShader) +type Geometry = 'Stage ('ShaderStage 'GeometryShader) +type Fragment = 'Stage ('ShaderStage 'FragmentShader) +type Compute = 'Stage ('ShaderStage 'ComputeShader) + +type Task = 'Stage ('MeshStage 'TaskShader) +type Mesh = 'Stage ('MeshStage 'MeshShader) + +type RayGeneration = 'Stage ('RayStage 'RayGenerationShader) +type Intersection = 'Stage ('RayStage 'IntersectionShader) +type AnyHit = 'Stage ('RayStage 'AnyHitShader) +type ClosestHit = 'Stage ('RayStage 'ClosestHitShader) +type Miss = 'Stage ('RayStage 'MissShader) +type Callable = 'Stage ('RayStage 'CallableShader) + + +instance Demotable Shader where + type Demote Shader = Shader + +instance Known Shader VertexShader where + known = VertexShader +instance Known Shader TessellationControlShader where + known = TessellationControlShader +instance Known Shader TessellationEvaluationShader where + known = TessellationEvaluationShader +instance Known Shader GeometryShader where + known = GeometryShader +instance Known Shader FragmentShader where + known = FragmentShader +instance Known Shader ComputeShader where + known = ComputeShader + +instance Demotable MeshShader where + type Demote MeshShader = MeshShader + +instance Known MeshShader 'TaskShader where + known = TaskShader +instance Known MeshShader 'MeshShader where + known = MeshShader + +instance Demotable RayShader where + type Demote RayShader = RayShader + +instance Known RayShader RayGenerationShader where + known = RayGenerationShader +instance Known RayShader IntersectionShader where + known = IntersectionShader +instance Known RayShader AnyHitShader where + known = AnyHitShader +instance Known RayShader ClosestHitShader where + known = ClosestHitShader +instance Known RayShader MissShader where + known = MissShader +instance Known RayShader CallableShader where + known = CallableShader + +instance Demotable Stage where + type Demote Stage = Stage + +instance Known Shader shader => Known Stage (ShaderStage shader) where + known = ShaderStage ( knownValue @shader ) +instance Known MeshShader meshShader => Known Stage (MeshStage meshShader) where + known = MeshStage ( knownValue @meshShader ) +instance Known RayShader rayShader => Known Stage (RayStage rayShader) where + known = RayStage ( knownValue @rayShader ) + +instance Demotable ExecutionModel where + type Demote ExecutionModel = ExecutionModel + +instance Known Stage stage => Known ExecutionModel ('Stage stage) where + known = Stage ( knownValue @stage ) +instance Known ExecutionModel Kernel where + known = Kernel + + +type family FromEnumShader (s :: Shader) :: Nat where + FromEnumShader VertexShader = 0 + FromEnumShader TessellationControlShader = 1 + FromEnumShader TessellationEvaluationShader = 2 + FromEnumShader GeometryShader = 3 + FromEnumShader FragmentShader = 4 + FromEnumShader ComputeShader = 5 + +type family FromEnumMeshShader (s :: MeshShader) :: Nat where + FromEnumMeshShader 'TaskShader = 5267 + FromEnumMeshShader 'MeshShader = 5268 + +type family FromEnumRayShader (s :: RayShader) :: Nat where + FromEnumRayShader RayGenerationShader = 5313 + FromEnumRayShader IntersectionShader = 5314 + FromEnumRayShader AnyHitShader = 5315 + FromEnumRayShader ClosestHitShader = 5316 + FromEnumRayShader MissShader = 5317 + FromEnumRayShader CallableShader = 5318 + +type family FromEnumStage (s :: Stage) :: Nat where + FromEnumStage (ShaderStage s) = FromEnumShader s + FromEnumStage (MeshStage s) = FromEnumMeshShader s + FromEnumStage (RayStage s) = FromEnumRayShader s + +type family FromEnumExecutionModel (em :: ExecutionModel) :: Nat where + FromEnumExecutionModel ('Stage s) = FromEnumStage s + FromEnumExecutionModel Kernel = 6 + +instance POrd ExecutionModel where + type Compare s1 s2 = FromEnumExecutionModel s1 `CmpNat` FromEnumExecutionModel s2 + +type family ShaderName (s :: Shader) :: Symbol where + ShaderName VertexShader = "Vertex shader" + ShaderName TessellationControlShader = "Tessellation Control shader" + ShaderName TessellationEvaluationShader = "Tessellation Evaluation shader" + ShaderName GeometryShader = "Geometry shader" + ShaderName FragmentShader = "Fragment shader" + ShaderName ComputeShader = "Compute shader" + +type family StageName (s :: Stage) :: Symbol where + StageName (ShaderStage s) = ShaderName s + StageName (MeshStage 'TaskShader) = "Task shader" + StageName (MeshStage 'MeshShader) = "Mesh shader" + StageName (RayStage RayGenerationShader) = "Ray Generation shader" + StageName (RayStage IntersectionShader) = "Ray Intersection shader" + StageName (RayStage AnyHitShader) = "Any Hit ray shader" + StageName (RayStage ClosestHitShader) = "Closest Hit ray shader" + StageName (RayStage MissShader) = "Ray Miss shader" + StageName (RayStage CallableShader) = "Ray Callable shader" + +type family ExecutionModelName (em :: ExecutionModel) :: Symbol where + ExecutionModelName ('Stage s) = StageName s + ExecutionModelName Kernel = "Compute kernel" + +type family NamedShader (k :: Symbol) (s :: Shader) :: Symbol where + NamedShader k s = ShaderName s `AppendSymbol` " named \"" `AppendSymbol` k `AppendSymbol` "\"" + +type family NamedStage (k :: Symbol) (s :: Stage) :: Symbol where + NamedStage k s = StageName s `AppendSymbol` " named \"" `AppendSymbol` k `AppendSymbol` "\"" + +type family NamedExecutionModel (k :: Symbol) (em :: ExecutionModel) :: Symbol where + NamedExecutionModel k em = ExecutionModelName em `AppendSymbol` " named \"" `AppendSymbol` k `AppendSymbol` "\"" + +-------------------------------------------------------------------------- +-- execution backends: whether Vulkan or OpenCL + +data Backend = Vulkan | OpenCL + deriving stock ( Eq, Show ) + +type family OtherBackend ( bk :: Backend ) :: Backend where + OtherBackend Vulkan = OpenCL + OtherBackend OpenCL = Vulkan + +instance Demotable Backend where + type Demote Backend = Backend +instance Known Backend Vulkan where + known = Vulkan +instance Known Backend OpenCL where + known = OpenCL + +type family BackendOf ( model :: ExecutionModel ) :: Backend where + BackendOf ( 'Stage _ ) = Vulkan + BackendOf Kernel = OpenCL + +backendOf :: ExecutionModel -> Backend +backendOf ( Stage _ ) = Vulkan +backendOf Kernel = OpenCL + +-------------------------------------------------------------------------- +-- additional execution model information that needs to be known at the type-level + +data TessellationMode + = ModeTriangles + | ModeQuads + | ModeIsolines + | ModePoints + deriving stock (Show, Eq, Ord, Enum, Bounded) + +type family ShowTessellationMode (mode :: TessellationMode) :: Symbol where + ShowTessellationMode ModeTriangles = "Triangles" + ShowTessellationMode ModeQuads = "Quads" + ShowTessellationMode ModeIsolines = "Isolines" + ShowTessellationMode ModePoints = "Points" + +data GeometryInputMode + = InputModePoints + | InputModeLines + | InputModeLinesAdjacency + | InputModeTriangles + | InputModeTrianglesAdjacency + deriving stock (Show, Eq, Ord, Enum, Bounded) + +type family ShowGeometryInputMode (mode :: GeometryInputMode) :: Symbol where + ShowGeometryInputMode InputModePoints + = "InputPoints" + ShowGeometryInputMode InputModeLines + = "InputLines" + ShowGeometryInputMode InputModeLinesAdjacency + = "InputLinesAdjacency" + ShowGeometryInputMode InputModeTriangles + = "(Input)Triangles" + ShowGeometryInputMode InputModeTrianglesAdjacency + = "InputTrianglesAdjacency" + +instance Demotable TessellationMode where + type Demote TessellationMode = TessellationMode + +instance Demotable GeometryInputMode where + type Demote GeometryInputMode = GeometryInputMode + +instance Known TessellationMode 'ModeTriangles where + known = ModeTriangles +instance Known TessellationMode 'ModeQuads where + known = ModeQuads +instance Known TessellationMode 'ModeIsolines where + known = ModeIsolines +instance Known TessellationMode 'ModePoints where + known = ModePoints + +instance Known GeometryInputMode 'InputModePoints where + known = InputModePoints +instance Known GeometryInputMode 'InputModeLines where + known = InputModeLines +instance Known GeometryInputMode 'InputModeLinesAdjacency where + known = InputModeLinesAdjacency +instance Known GeometryInputMode 'InputModeTriangles where + known = InputModeTriangles +instance Known GeometryInputMode 'InputModeTrianglesAdjacency where + known = InputModeTrianglesAdjacency + +data ShaderInfo (n :: Type) (s :: Shader) where + VertexShaderInfo + :: ShaderInfo n VertexShader + TessellationControlShaderInfo + :: n -- input size + -> n -- output size + -> Maybe TessellationMode + -> ShaderInfo n TessellationControlShader + TessellationEvaluationShaderInfo + :: n -- input size + -> TessellationMode + -> ShaderInfo n TessellationEvaluationShader + GeometryShaderInfo + :: n -- input size + -> GeometryInputMode + -> ShaderInfo n GeometryShader + FragmentShaderInfo + :: ShaderInfo n FragmentShader + ComputeShaderInfo + :: (n,n,n) -- shader local size + -> ShaderInfo n ComputeShader + +deriving stock instance Show n => Show (ShaderInfo n s) +deriving stock instance Eq n => Eq (ShaderInfo n s) +deriving stock instance Ord n => Ord (ShaderInfo n s) + +data RayShaderInfo (s :: RayShader) where + RayGenerationShaderInfo :: RayShaderInfo RayGenerationShader + IntersectionShaderInfo :: RayShaderInfo IntersectionShader + AnyHitShaderInfo :: RayShaderInfo AnyHitShader + ClosestHitShaderInfo :: RayShaderInfo ClosestHitShader + MissShaderInfo :: RayShaderInfo MissShader + CallableShaderInfo :: RayShaderInfo CallableShader + +type family MkRayShaderInfo ( s :: RayShader ) :: RayShaderInfo s where + MkRayShaderInfo RayGenerationShader = RayGenerationShaderInfo + MkRayShaderInfo IntersectionShader = IntersectionShaderInfo + MkRayShaderInfo AnyHitShader = AnyHitShaderInfo + MkRayShaderInfo ClosestHitShader = ClosestHitShaderInfo + MkRayShaderInfo MissShader = MissShaderInfo + MkRayShaderInfo CallableShader = CallableShaderInfo + +deriving stock instance Show (RayShaderInfo s) +deriving stock instance Eq (RayShaderInfo s) +deriving stock instance Ord (RayShaderInfo s) + +data ExecutionInfo (n :: Type) (em :: ExecutionModel) where + ShaderExecutionInfo :: ShaderInfo n s -> ExecutionInfo n ('Stage ('ShaderStage s)) + KernelInfo + :: (n,n,n) -- kernel local size + -> ExecutionInfo n Kernel + -- ray shaders don't need extra info (at least at the moment) + RayShaderInfo :: RayShaderInfo s -> ExecutionInfo n ('Stage ('RayStage s)) + +type VertexInfo = 'ShaderExecutionInfo 'VertexShaderInfo +type TessellationControlInfo i j m = 'ShaderExecutionInfo ( 'TessellationControlShaderInfo i j m) +type TessellationEvaluationInfo i m = 'ShaderExecutionInfo ( 'TessellationEvaluationShaderInfo i m) +type GeometryInfo i m = 'ShaderExecutionInfo ('GeometryShaderInfo i m) +type FragmentInfo = 'ShaderExecutionInfo 'FragmentShaderInfo +type ComputeInfo ijk = 'ShaderExecutionInfo ('ComputeShaderInfo ijk) + +deriving stock instance Show n => Show (ExecutionInfo n s) +deriving stock instance Eq n => Eq (ExecutionInfo n s) +deriving stock instance Ord n => Ord (ExecutionInfo n s) + +modelOf :: ExecutionInfo n em -> ExecutionModel +modelOf (ShaderExecutionInfo VertexShaderInfo) + = Stage (ShaderStage VertexShader) +modelOf (ShaderExecutionInfo (TessellationControlShaderInfo {})) + = Stage (ShaderStage TessellationControlShader) +modelOf (ShaderExecutionInfo (TessellationEvaluationShaderInfo {})) + = Stage (ShaderStage TessellationEvaluationShader) +modelOf (ShaderExecutionInfo (GeometryShaderInfo {})) + = Stage (ShaderStage GeometryShader) +modelOf (ShaderExecutionInfo FragmentShaderInfo) + = Stage (ShaderStage FragmentShader) +modelOf (ShaderExecutionInfo (ComputeShaderInfo {})) + = Stage (ShaderStage ComputeShader) +modelOf (KernelInfo {}) + = Kernel +modelOf (RayShaderInfo RayGenerationShaderInfo) + = Stage (RayStage RayGenerationShader) +modelOf (RayShaderInfo IntersectionShaderInfo ) + = Stage (RayStage IntersectionShader) +modelOf (RayShaderInfo AnyHitShaderInfo) + = Stage (RayStage AnyHitShader) +modelOf (RayShaderInfo ClosestHitShaderInfo) + = Stage (RayStage ClosestHitShader) +modelOf (RayShaderInfo MissShaderInfo) + = Stage (RayStage MissShader) +modelOf (RayShaderInfo CallableShaderInfo) + = Stage (RayStage CallableShader) + + +instance Demotable (ShaderInfo Nat s) where + type Demote (ShaderInfo Nat s) = ShaderInfo Word32 s + +instance Known (ShaderInfo Nat VertexShader) VertexShaderInfo where + known = VertexShaderInfo +instance ( KnownNat inputSize + , KnownNat outputSize + , Known (Maybe TessellationMode) mbMode + ) + => Known + (ShaderInfo Nat TessellationControlShader) + (TessellationControlShaderInfo inputSize outputSize mbMode) where + known = TessellationControlShaderInfo + ( knownValue @inputSize ) + ( knownValue @outputSize ) + ( knownValue @mbMode ) +instance (KnownNat inputSize, Known TessellationMode mode) + => Known + (ShaderInfo Nat TessellationEvaluationShader) + (TessellationEvaluationShaderInfo inputSize mode) where + known = TessellationEvaluationShaderInfo + ( knownValue @inputSize ) + ( knownValue @mode ) +instance (KnownNat inputSize, Known GeometryInputMode mode) + => Known (ShaderInfo Nat GeometryShader) + (GeometryShaderInfo inputSize mode) where + known = GeometryShaderInfo + ( knownValue @inputSize ) + ( knownValue @mode ) +instance Known (ShaderInfo Nat FragmentShader) FragmentShaderInfo where + known = FragmentShaderInfo +instance ( Known (Nat,Nat,Nat) ijk ) + => Known (ShaderInfo Nat ComputeShader) (ComputeShaderInfo ijk) where + known = ComputeShaderInfo ( knownValue @ijk ) + + +instance Demotable (RayShaderInfo s) where + type Demote (RayShaderInfo s) = RayShaderInfo s + +instance Known ( RayShaderInfo RayGenerationShader ) RayGenerationShaderInfo where + known = RayGenerationShaderInfo +instance Known ( RayShaderInfo IntersectionShader ) IntersectionShaderInfo where + known = IntersectionShaderInfo +instance Known ( RayShaderInfo AnyHitShader ) AnyHitShaderInfo where + known = AnyHitShaderInfo +instance Known ( RayShaderInfo ClosestHitShader ) ClosestHitShaderInfo where + known = ClosestHitShaderInfo +instance Known ( RayShaderInfo MissShader ) MissShaderInfo where + known = MissShaderInfo +instance Known ( RayShaderInfo CallableShader ) CallableShaderInfo where + known = CallableShaderInfo + +instance Demotable (ExecutionInfo Nat s) where + type Demote (ExecutionInfo Nat s) = ExecutionInfo Word32 s + +instance Known (ShaderInfo Nat s) info + => Known (ExecutionInfo Nat ('Stage ('ShaderStage s))) + (ShaderExecutionInfo info) + where + known = ShaderExecutionInfo ( knownValue @info ) +instance ( Known (Nat,Nat,Nat) ijk ) + => Known (ExecutionInfo Nat 'Kernel) (KernelInfo ijk) where + known = KernelInfo ( knownValue @ijk) +instance Known (RayShaderInfo s) info + => Known (ExecutionInfo Nat ('Stage ('RayStage s))) + ('RayShaderInfo info) + where + known = RayShaderInfo ( knownValue @info ) diff --git a/src/SPIRV/Storage.hs b/src/SPIRV/Storage.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Storage.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: SPIRV.Storage + +This module enumerates SPIR-V storage classes. + +These are used both at the type-level and at the value-level. + +See the SPIR-V specification, §3.7 __Storage Class__. + +-} + +module SPIRV.Storage where + +-- base +import Data.Word + ( Word32 ) +import GHC.TypeNats + ( Nat ) + +-- fir +import Data.Binary.Class.Put + ( Put(..) ) +import Data.Type.Known + ( Demotable(Demote), Known(known), knownValue ) +import Data.Type.POrd + ( POrd(..) ) + +-------------------------------------------------- + +data StorageClass + = UniformConstant + | Input + | Uniform + | Output + | Workgroup + | CrossWorkgroup + | Private + | Function + | Generic + | PushConstant + | AtomicCounter + | Image + | StorageBuffer + | RayStorage RayStorage + deriving stock (Show, Eq, Ord) + +instance Put StorageClass where + put UniformConstant = put @Word32 0 + put Input = put @Word32 1 + put Uniform = put @Word32 2 + put Output = put @Word32 3 + put Workgroup = put @Word32 4 + put CrossWorkgroup = put @Word32 5 + put Private = put @Word32 6 + put Function = put @Word32 7 + put Generic = put @Word32 8 + put PushConstant = put @Word32 9 + put AtomicCounter = put @Word32 10 + put Image = put @Word32 11 + put StorageBuffer = put @Word32 12 + put (RayStorage s) = put s + wordCount _ = 1 + +data DataOrigin + = Lifetime + | Incoming + deriving stock (Show, Eq, Ord) + +data RayStorage + = CallableData DataOrigin + | RayPayload DataOrigin + | HitAttribute + | ShaderRecordBuffer + deriving stock (Show, Eq, Ord) + +instance Put RayStorage where + put (CallableData Lifetime) = put @Word32 5328 + put (CallableData Incoming) = put @Word32 5329 + put (RayPayload Lifetime) = put @Word32 5338 + put (RayPayload Incoming) = put @Word32 5342 + put HitAttribute = put @Word32 5339 + put ShaderRecordBuffer = put @Word32 5343 + wordCount _ = 1 + +instance Demotable StorageClass where + type Demote StorageClass = StorageClass + +instance Known StorageClass UniformConstant where + known = UniformConstant +instance Known StorageClass Input where + known = Input +instance Known StorageClass Uniform where + known = Uniform +instance Known StorageClass Output where + known = Output +instance Known StorageClass Workgroup where + known = Workgroup +instance Known StorageClass CrossWorkgroup where + known = CrossWorkgroup +instance Known StorageClass Private where + known = Private +instance Known StorageClass Function where + known = Function +instance Known StorageClass Generic where + known = Generic +instance Known StorageClass PushConstant where + known = PushConstant +instance Known StorageClass AtomicCounter where + known = AtomicCounter +instance Known StorageClass Image where + known = Image +instance Known StorageClass StorageBuffer where + known = StorageBuffer +instance Known RayStorage s => Known StorageClass ('RayStorage s) where + known = RayStorage (knownValue @s) + +instance Demotable DataOrigin where + type Demote DataOrigin = DataOrigin + +instance Known DataOrigin Lifetime where + known = Lifetime +instance Known DataOrigin Incoming where + known = Incoming + +instance Demotable RayStorage where + type Demote RayStorage = RayStorage + +instance Known DataOrigin origin => Known RayStorage (CallableData origin) where + known = CallableData (knownValue @origin) +instance Known DataOrigin origin => Known RayStorage (RayPayload origin) where + known = RayPayload (knownValue @origin) +instance Known RayStorage HitAttribute where + known = HitAttribute +instance Known RayStorage ShaderRecordBuffer where + known = ShaderRecordBuffer + + + +instance POrd StorageClass where + type Compare x y = Compare (StorageClassToNat x) (StorageClassToNat y) + +type family StorageClassToNat (s :: StorageClass) :: Nat where + StorageClassToNat UniformConstant = 0 + StorageClassToNat Input = 1 + StorageClassToNat Uniform = 2 + StorageClassToNat Output = 3 + StorageClassToNat Workgroup = 4 + StorageClassToNat CrossWorkgroup = 5 + StorageClassToNat Private = 6 + StorageClassToNat Function = 7 + StorageClassToNat Generic = 8 + StorageClassToNat PushConstant = 9 + StorageClassToNat AtomicCounter = 10 + StorageClassToNat Image = 11 + StorageClassToNat StorageBuffer = 12 + StorageClassToNat ('RayStorage r) = RayStorageClassToNat r + +type family RayStorageClassToNat (r :: RayStorage) :: Nat where + RayStorageClassToNat (CallableData Lifetime) = 5328 + RayStorageClassToNat (CallableData Incoming) = 5329 + RayStorageClassToNat (RayPayload Lifetime) = 5338 + RayStorageClassToNat (RayPayload Incoming) = 5342 + RayStorageClassToNat HitAttribute = 5339 + RayStorageClassToNat ShaderRecordBuffer = 5343 diff --git a/src/SPIRV/Synchronisation.hs b/src/SPIRV/Synchronisation.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Synchronisation.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| +Module: SPIRV.Synchronisation + +Defines synchronisation scopes and related memory lock semantics. + +See the SPIR-V specification: + + * §3.25 __Memory Semantics__, + * §3.27 __Scope__ (synchronisation scopes). + +-} + +module SPIRV.Synchronisation + ( SynchronisationScope(..) + , MemorySemantics(..) + , OrderingSemantics(..) + , LockSemantics(..) + , MemoryType(..) + , synchronisationScope + , memorySemanticsBitmask + ) where + +-- base +import Data.Bits + ( Bits ( (.|.), bit ) ) +import Data.Word + ( Word32 ) + +-- fir +import Data.Binary.Class.Put + ( Put(..), PutWord32Enum(..) ) +import Data.Type.Known + ( Demotable(Demote), Known(known) ) + +-------------------------------------------------- + +data SynchronisationScope + = CrossDevice + | Device + | Workgroup + | Subgroup + | Invocation + | QueueFamily + | ShaderCall + deriving stock ( Eq, Ord, Show, Enum, Bounded ) + deriving Put via ( PutWord32Enum SynchronisationScope ) + +synchronisationScope :: SynchronisationScope -> Word32 +synchronisationScope = fromIntegral . fromEnum + +instance Demotable SynchronisationScope where + type Demote SynchronisationScope = SynchronisationScope + +instance Known SynchronisationScope 'CrossDevice where + known = CrossDevice + +instance Known SynchronisationScope 'Device where + known = Device + +instance Known SynchronisationScope 'Workgroup where + known = Workgroup + +instance Known SynchronisationScope 'Subgroup where + known = Subgroup + +instance Known SynchronisationScope 'Invocation where + known = Invocation + +instance Known SynchronisationScope 'QueueFamily where + known = QueueFamily + +instance Known SynchronisationScope 'ShaderCall where + known = ShaderCall + +data MemorySemantics + = MemorySemantics + { orderingSemantics :: OrderingSemantics + , memoryTypes :: [ MemoryType ] + } + deriving stock ( Eq, Show ) + +data OrderingSemantics + = Lock [ LockSemantics ] + | SequentiallyConsistent + deriving stock ( Eq, Show ) + +ordBitmask :: OrderingSemantics -> Word32 +ordBitmask = \case + SequentiallyConsistent -> 16 + Lock locks -> case ( Acquire `elem` locks, Release `elem` locks ) of + ( True , True ) -> 8 + ( True , False ) -> 2 + ( False, True ) -> 4 + ( False, False ) -> 0 + +memorySemanticsBitmask :: MemorySemantics -> Word32 +memorySemanticsBitmask ( MemorySemantics ord mems ) = ordBitmask ord .|. memBitmask mems + +data LockSemantics + = Acquire + | Release + deriving stock ( Eq, Show ) + +instance Put MemorySemantics where + wordCount _ = 1 + put memSem = put ( memorySemanticsBitmask memSem ) + +instance Put (Maybe MemorySemantics) where + wordCount _ = 1 + put Nothing = put @Word32 0 + put (Just sem) = put sem + +data MemoryType + = UniformMemory + | SubgroupMemory + | WorkgroupMemory + | CrossWorkgroupMemory + | AtomicCounterMemory + | ImageMemory + | OutputMemory + deriving stock ( Eq, Ord, Show, Enum, Bounded ) + +memBitmask :: [MemoryType] -> Word32 +memBitmask = foldl (.|.) 0 . map memBit + +memBit :: MemoryType -> Word32 +memBit = bit . ( + 6 ) . fromEnum diff --git a/src/SPIRV/Version.hs b/src/SPIRV/Version.hs new file mode 100644 --- /dev/null +++ b/src/SPIRV/Version.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DerivingStrategies #-} + +{-| +Module: SPIRV.Version + +Handles SPIR-V version numbers. + +-} + +module SPIRV.Version + ( Version(..), magicNo ) + where + +-- base +import Data.Bits + ( Bits(shiftL) ) +import Data.Word + ( Word8, Word32 ) + +-- fir +import Data.Binary.Class.Put + ( Put(..) ) + +---------------------------------------------------------------------------- + +data Version = Version { major :: Word8, minor :: Word8 } + deriving stock ( Eq, Ord ) + +instance Show Version where + show (Version majorVer minorVer) + = show majorVer ++ "." ++ show minorVer + +instance Put Version where + put (Version majorVer minorVer) = put ver + where + ver :: Word32 + ver = (fromIntegral majorVer) `shiftL` 16 + + (fromIntegral minorVer) `shiftL` 8 + wordCount _ = 1 + +magicNo :: Word32 +magicNo = 0x07230203 diff --git a/test/CabalTests.hs b/test/CabalTests.hs new file mode 100644 --- /dev/null +++ b/test/CabalTests.hs @@ -0,0 +1,62 @@ +module CabalTests ( tests ) where + +-- cabal +import qualified Distribution.TestSuite as Cabal + +-- filepath +import System.FilePath + ( () ) + +-- fir-tests +import Folders + ( Folder(Folder) ) +import Test + ( Test, TestOutput(..), TestFailure(..) + , runTest + ) +import Tests + ( allTests ) + +-------------------------------------------------- +-- package up tests for cabal + +tests :: IO [ Cabal.Test ] +tests = pure ( map groupFolderTests allTests ) + +groupFolderTests :: Folder (String, Test) -> Cabal.Test +groupFolderTests ( Folder folderName folderTests ) + = Cabal.Group folderName True + $ map ( \( testName, testType ) -> + mkCabalTest folderName testName testType + ) + folderTests + +mkCabalTest :: String -> String -> Test -> Cabal.Test +mkCabalTest folderName testName testType + = Cabal.Test + $ Cabal.TestInstance + { Cabal.run = Cabal.Finished . cabalResult <$> runTest testType testPath + , Cabal.name = testPath + , Cabal.tags = [ folderName, show testType ] + , Cabal.options = [] + , Cabal.setOption = \ _ _ -> Left "Test does not have any options." + } + + where + testPath :: FilePath + testPath = folderName testName + +cabalResult :: TestOutput -> Cabal.Result +cabalResult Success = Cabal.Pass +cabalResult NewTest + = Cabal.Error "New test: created 'golden' file from test run." +cabalResult (Failure CGOutputParseError) + = Cabal.Error "Could not parse result of code-generation. Maybe something crashed?" +cabalResult (Failure OtherError) + = Cabal.Error "Encountered a problem loading test in ghci. Maybe something crashed?" +cabalResult (Failure FIRNotBuiltOrUnusableError) + = Cabal.Error + "Could not load 'fir' library.\n\ + \Possible cause: library not built, or wrong version." +cabalResult (Failure failure) + = Cabal.Fail (show failure) diff --git a/test/Folders.hs b/test/Folders.hs new file mode 100644 --- /dev/null +++ b/test/Folders.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} + +module Folders where + +-- base +import Control.Monad + ( forM ) + +-- filepath +import System.FilePath + ( () ) + +-- fir-tests +import Test + ( Test, TestOutput(..) + , runTest + ) + +data Folder a = Folder String [a] + deriving stock (Functor, Foldable, Traversable) + +------------------------------------------------------------------------------------------ +-- running tests on folders + +runTestsP :: (String -> String -> Test -> Bool) + -> [ Folder (String, Test) ] + -> IO [ Folder (String, Test, TestOutput) ] +runTestsP f + = runTests + . map ( \ (Folder g tests) -> Folder g (filter ( \(p,t) -> f g p t ) tests) ) + +runTests :: [ Folder (String, Test) ] + -> IO [ Folder (String, Test, TestOutput) ] +runTests + = traverse + ( \ (Folder folderName folderTests) -> + Folder folderName <$> + forM folderTests \ (testName, testType) -> + (testName, testType, ) + <$> runTest testType ( folderName testName ) + ) + +runTestsFromFolder + :: String + -> [ Folder (String, Test) ] + -> IO [ Folder (String, Test, TestOutput) ] +runTestsFromFolder folderName = runTestsP ( \ x _ _ -> x == folderName ) + + +------------------------------------------------------------------------------------------ +-- displaying test result folders + +deriving stock instance Show (Folder (String, Test)) + +instance Show (Folder (String, Test, TestOutput)) where + show ( Folder folderName testResults ) + = padRToLength 15 folderName + <> "( " <> showPaddedL 2 passes <> " / " <> showPaddedL 2 total <> " )" + <> foldMap showTestResult testResults + <> "\n" + where + total, passes :: Int + total = length testResults + passes = length . filter ( \(_,_,res) -> res == Success ) $ testResults + showTestResult :: (String, Test, TestOutput) -> String + showTestResult (testName, testType, testResult) + = "\n " <> padRToLength 30 testName + <> padRToLength 9 (show testType) <> ": " <> show testResult + +instance {-# OVERLAPPING #-} Show [Folder (String, Test, TestOutput)] where + show = unlines . map show + + +-- utility padding functions + +padRToLength :: Int -> String -> String +padRToLength n s + | lg >= n = s + | otherwise = s <> replicate (n - lg) ' ' + where lg = length s + +padLToLength :: Int -> String -> String +padLToLength n s + | lg >= n = s + | otherwise = replicate (n - lg) ' ' <> s + where lg = length s + +showPaddedR :: Show a => Int -> a -> String +showPaddedR n = padRToLength n . show + +showPaddedL :: Show a => Int -> a -> String +showPaddedL n = padLToLength n . show diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test where + +-- base +import Control.Concurrent + ( forkIO, newEmptyMVar, putMVar, takeMVar ) +import Control.Monad + ( when ) +import Data.Maybe + ( fromMaybe ) +import System.IO + ( hClose ) + +-- bytestring +import Data.ByteString + ( ByteString ) +import qualified Data.ByteString as ByteString + ( readFile, writeFile + , hGetContents, hPut + , null, take + ) +import qualified Data.ByteString.Char8 as ByteString + ( lines, unlines, stripSuffix ) + +-- directory +import System.Directory + ( doesFileExist, renameFile, removeFile ) + +-- filepath +import System.FilePath + ( (), (<.>), splitDirectories ) +import qualified System.FilePath.Posix as Posix + ( joinPath ) + +-- process +import System.Process + ( proc, createProcess + , CreateProcess + ( std_in, std_out, std_err ) + , StdStream + ( CreatePipe ) + , waitForProcess + ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( pack, lines + , take, drop, dropWhile, dropWhileEnd + , dropAround, breakOn, isPrefixOf + , null, replace + ) +import qualified Data.Text.Encoding as Text + ( encodeUtf8, decodeUtf8With ) +import qualified Data.Text.Encoding.Error as Text + ( lenientDecode ) + +-- fir +import FIR + ( CompilerFlag(..) ) + +-------------------------------------------------- + +data Test + = Typecheck + | CodeGen + | Validate + deriving stock ( Eq, Show ) + +data TestFailure + = MissingSource + | WrongTypecheckOutput + | ExpectedTypecheck + | UnexpectedTypecheck + | CodeGenFail Text + | ValidateFail Text + | CGOutputParseError + | FIRNotBuiltOrUnusableError + | OtherError + deriving stock ( Eq, Show ) + +data TestOutput + = Failure TestFailure + | Success + | NewTest + deriving stock ( Eq, Show ) + +runTest :: Test -> FilePath -> IO TestOutput +runTest Typecheck = typeCheck +runTest CodeGen = codeGen +runTest Validate = validate + +-------------------------------------------------- +-- truly disgusting testing setup + +validator :: FilePath +validator = "spirv-val" + +codeGen, validate :: FilePath -> IO TestOutput +codeGen testName = compileTest [Debug, Assert, NoCode] testName +validate testName = compileTest [Debug, Assert] testName + +-- | Run an executable with the given arguments, feeding it the given input +-- on stdin, and return what it wrote to stdout and stderr. +readProcessOutput :: FilePath -> [String] -> ByteString -> IO (ByteString, ByteString) +readProcessOutput exe args input = do + (Just inHandle, Just outHandle, Just errHandle, processHandle) + <- createProcess + ( proc exe args ) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + outVar <- newEmptyMVar + errVar <- newEmptyMVar + _ <- forkIO $ ByteString.hGetContents outHandle >>= putMVar outVar + _ <- forkIO $ ByteString.hGetContents errHandle >>= putMVar errVar + ByteString.hPut inHandle input + hClose inHandle + out <- takeMVar outVar + err <- takeMVar errVar + _ <- waitForProcess processHandle + pure (out, err) + +-- | Run GHC in the package environment of the cabal project, which provides +-- the in-place build of 'fir'. +-- +-- A package environment file in the project directory is not reliable: +-- every cabal invocation with @write-ghc-environment-files@ rewrites it, +-- including those of the Haskell Language Server with its own build directory. +readGhcOutput :: [String] -> ByteString -> IO (ByteString, ByteString) +readGhcOutput args = readProcessOutput "cabal" ( [ "exec", "--verbose=0", "--", "ghc" ] ++ args ) + +decodeOutput :: ByteString -> Text +decodeOutput = Text.decodeUtf8With Text.lenientDecode + +compileTest :: [CompilerFlag] -> FilePath -> IO TestOutput +compileTest flags testName = do + srcExists <- doesFileExist src + case srcExists of + False -> pure ( Failure MissingSource ) + True -> + do + (out, err) <- + readGhcOutput + [ "--interactive" + , src + , "-w" + , "-package", "fir" + , "-threaded" + ] + ( Text.encodeUtf8 ( compile <> "\n:q\n" ) ) + + let res = parseCGOutput ( decodeOutput out ) + res' <- case res of + Failure ExpectedTypecheck + -> do ByteString.writeFile test err + pure res + Failure (CodeGenFail _) + -> do ByteString.writeFile test out + pure res + Failure _ + -> do let errLines = dropWhile ignoreLineText . linesText $ decodeOutput err + case errLines of + ( l1 : _ ) + | Text.take 43 l1 == ": cannot satisfy -package fir" + -> pure (Failure FIRNotBuiltOrUnusableError) + _ -> do ByteString.writeFile test err + pure res + Success + -> do failExists <- doesFileExist test + when ( NoCode `elem` flags && failExists ) ( removeFile test ) + pure res + NewTest + -> pure res + if res' /= Success || NoCode `elem` flags + then pure res' + else + do (_, valErr) <- readProcessOutput validator [ spv ] "" + if ByteString.null valErr + then do removeFile spv + failExists <- doesFileExist test + when failExists ( removeFile test ) + pure Success + else do ByteString.writeFile test valErr + renameFile spv (spv <.> "fail") + pure ( Failure ( ValidateFail ( decodeOutput valErr ) ) ) + + where dir = "test" "Tests" + src = dir testName <.> "hs" + test = dir testName <.> "fail" + spv = dir testName <.> "spv" + compile = "compileTo " + <> Text.pack (show spv) + <> " " + <> Text.pack (show flags) + <> " program" + +typeCheck :: FilePath -> IO TestOutput +typeCheck testName = do + srcExists <- doesFileExist src + case srcExists of + False -> pure ( Failure MissingSource ) + True -> + do + (_, testContents) <- + readGhcOutput + [ src + , "-w" + , "-fno-code" + , "-package", "fir" + , "-threaded" + ] + "" + let mbTcOutput = normalisePath <$> parseTcOutput testContents + + case mbTcOutput of + Nothing -> pure ( Failure FIRNotBuiltOrUnusableError ) + Just tcOutput -> do + + goldenExists <- doesFileExist gold + + if goldenExists + then do + golden <- ByteString.readFile gold + if normaliseDiagnostics golden == normaliseDiagnostics tcOutput + then pure Success + else do + ByteString.writeFile test tcOutput + if golden == cleanTc + then pure ( Failure ExpectedTypecheck) + else + if tcOutput == cleanTc + then pure ( Failure UnexpectedTypecheck ) + else pure ( Failure WrongTypecheckOutput ) + + else do ByteString.writeFile gold tcOutput + pure NewTest + + where dir = "test" "Tests" + src = dir testName <.> "hs" + gold = dir testName <.> "golden" + test = dir testName <.> "fail" + -- GHC refers to the source file using the path separators of the platform: + -- use forward slashes, so that the expected output is the same on all platforms. + normalisePath :: ByteString -> ByteString + normalisePath + = Text.encodeUtf8 + . Text.replace ( Text.pack src ) ( Text.pack ( Posix.joinPath ( splitDirectories src ) ) ) + . decodeOutput + +-- | Normalise diagnostics, for comparison with expected diagnostics, which might +-- have been produced on a different platform: +-- +-- - use LF line endings (the golden files can be checked out with CRLF line endings), +-- - GHC replaces some Unicode characters in its diagnostics with ASCII substitutes +-- when the locale doesn't support Unicode (e.g. with most Windows code pages): +-- make these substitutions. +normaliseDiagnostics :: ByteString -> Text +normaliseDiagnostics + = Text.replace "\r\n" "\n" + . Text.replace "\x2018" "`" + . Text.replace "\x2019" "'" + . Text.replace "\x2022" "*" + . decodeOutput + +cleanTc :: ByteString +cleanTc = "No type-checking errors." + +ignoreLineBS :: ByteString -> Bool +ignoreLineBS string + | ByteString.null string + || ByteString.take 4 string == "GHCi" + || ByteString.take 26 string == "Loaded package environment" + = True + | otherwise + = False + +ignoreLineText :: Text -> Bool +ignoreLineText string + | Text.null string + || Text.take 4 string == "GHCi" + || Text.take 26 string == "Loaded package environment" + || Text.take 30 string == "Using default language edition" + = True + | otherwise + = False + +-- Split GHC output into lines, accepting both LF and CRLF line endings +-- (GHC uses CRLF on Windows). + +linesBS :: ByteString -> [ ByteString ] +linesBS = map ( \ l -> fromMaybe l ( ByteString.stripSuffix "\r" l ) ) . ByteString.lines + +linesText :: Text -> [ Text ] +linesText = map ( Text.dropWhileEnd ( == '\r' ) ) . Text.lines + +parseTcOutput :: ByteString -> Maybe ByteString +parseTcOutput contents = go ( dropWhile ignoreLineBS ( linesBS contents ) ) + where + go :: [ByteString] -> Maybe ByteString + go [] = Just cleanTc + go ls@(l:_) + | ByteString.take 43 l == ": cannot satisfy -package fir" + = Nothing + | otherwise + = Just $ ByteString.unlines ls + +parseCGOutput :: Text -> TestOutput +parseCGOutput contents + = let ls = dropWhile ignoreLineText (linesText contents) + in case ls of + l1 : l2 : l3 : _ + | Text.take 8 l1 == "[1 of 1]" + -> case l2 of + "Ok, one module loaded." + -> let l3' = Text.drop 2 + . Text.dropWhile ( /= '>' ) + $ l3 + in case Text.breakOn " " l3' of + ( "Left", rest ) + -> Failure ( CodeGenFail + ( Text.dropAround (== '\"' ) + . Text.drop 1 + $ rest + ) + ) + ( "Right", _) + -> Success + _ -> Failure CGOutputParseError + _ | "Failed," `Text.isPrefixOf` l2 + -> Failure ExpectedTypecheck + | otherwise + -> Failure OtherError + _ -> Failure OtherError diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,187 @@ +module Tests where + +-- fir-tests +import Folders + ( Folder(Folder) + , runTests, runTestsP, runTestsFromFolder + ) +import Test + ( Test(..), TestOutput ) + +-------------------------------------------------- + +runAllTestsP :: (String -> String -> Test -> Bool) + -> IO [ Folder (String, Test, TestOutput) ] +runAllTestsP f = runTestsP f allTests + +runAllTests :: IO [ Folder (String, Test, TestOutput) ] +runAllTests = runTests allTests + +runAllTestsFromFolder :: String -> IO [ Folder (String, Test, TestOutput) ] +runAllTestsFromFolder = flip runTestsFromFolder allTests + +-------------------------------------------------- + +allTests :: [ Folder (String, Test) ] +allTests + = [ Folder "Array" + [ ( "Applicative" , Validate ) + , ( "ApplicativeConvert", Validate ) + , ( "Runtime" , Typecheck ) + ] + , Folder "Atomics" + [ ( "Operations" , Validate ) + , ( "FloatBitwise", Typecheck ) + ] + , Folder "Bits" + [ ( "BitCast" , Validate ) + , ( "Bits" , Validate ) + , ( "ZipBits" , Validate ) + , ( "BitReverse", Validate ) + ] + , Folder "Builtins" + [ ( "SampleId" , Validate ) + , ( "SharedBuiltin", Validate ) + ] + , Folder "Components" + [ ( "FloatInt" , Typecheck ) + , ( "FloatWidth", Typecheck ) + , ( "IntWidth" , Typecheck ) + , ( "Sign" , Validate ) + ] + , Folder "Definitions" + [ ( "Descriptors" , Typecheck ) + , ( "OriginLowerLeft", Typecheck ) + , ( "PushConstant" , Typecheck ) + , ( "UniformRuntimeArray", Typecheck ) + ] + , Folder "Control" + [ ( "BreakContinueNested", Validate ) + , ( "BreakInCondition" , Validate ) + , ( "BreakNested" , Validate ) + , ( "DeadCode" , Validate ) + , ( "Def" , Validate ) + , ( "Loop1" , Validate ) + , ( "Loop2" , Validate ) + , ( "Loop3" , Validate ) + , ( "LoopCondition" , Validate ) + , ( "LoopsNested" , Validate ) + , ( "RayQueryVariable" , Validate ) + , ( "Selection" , Validate ) + , ( "Switch" , Validate ) + , ( "TemporaryBranches" , Validate ) + , ( "TemporaryFunctions" , Validate ) + , ( "TemporaryLoop" , Validate ) + , ( "TemporarySetter" , Validate ) + ] + , Folder "Debug" + [ ( "Printf", Validate ) + ] + , Folder "Geometry" + [ ( "Geometry" , Validate ) + , ( "NotGeometry", Typecheck ) + ] + , Folder "Groups" + [ ( "GroupAdd", Validate ) + ] + , Folder "Images" + [ ( "Gather" , Validate ) + , ( "ReadWrite", Validate ) + , ( "Sample" , Validate ) + ] + , Folder "Inference" + [ ( "Ising1", Typecheck ) + , ( "Ising2", Typecheck ) + ] + , Folder "Interface" + [ ( "ComponentMismatch", Typecheck ) + , ( "ExtraOutput" , Typecheck ) + , ( "InvalidComponent" , Typecheck ) + , ( "MissingInput" , Typecheck ) + ] + , Folder "Layout" + [ ( "Copy" , Validate ) + , ( "DescriptorArray" , Validate ) + , ( "FunctionArgument", Validate ) + , ( "LocalVariables" , Validate ) + , ( "Matrices" , Validate ) + , ( "NestedUniform" , Validate ) + , ( "Offsets" , Validate ) + , ( "PerVertexBlocks" , Validate ) + , ( "Products" , Validate ) + , ( "PushConstant" , Validate ) + , ( "RuntimeArray" , Validate ) + , ( "Selection" , Validate ) + , ( "StructPadding" , Validate ) + ] + , Folder "Matrix" + [ ( "Applicative", Validate ) + ] + , Folder "Module" + [ ( "DiffStageDiffName", Validate ) + , ( "DiffStageSameName", Validate ) + , ( "SameStageDiffName", Validate ) + , ( "SameStageSameName", Typecheck ) + ] + , Folder "OpenCL" + [ ( "Kernel", Validate ) + ] + , Folder "Optics" + [ ( "ASTIndices" , Validate ) + , ( "ASTProducts" , Validate ) + , ( "MVP1" , Validate ) + , ( "MVP2" , Validate ) + , ( "NestedOfType" , Validate ) + , ( "NoMatrixIndex" , Typecheck ) + , ( "NoStructField" , Typecheck ) + , ( "NoStructIndex" , Typecheck ) + , ( "NoVectorIndex" , Typecheck ) + , ( "Overlapping" , Typecheck ) + , ( "ProductIndices", Typecheck ) + , ( "PureProducts" , Typecheck ) + , ( "UnarySwizzle" , Validate ) + , ( "Various" , Validate ) + ] + , Folder "PrimOps" + [ ( "Rounding", Validate) + ] + , Folder "ProgramState" + [ ( "Shadowing", Validate) + ] + , Folder "Small" + [ ( "HalfArithmetic" , Validate ) + , ( "HalfInputOutput", Validate ) + , ( "IntArithmetic" , Validate ) + , ( "IntInputOutput" , Validate ) + ] + , Folder "Tessellation" + [ ( "Control" , Validate ) + , ( "Evaluation", Validate ) + ] + , Folder "Unicode" + [ ( "Syntax", Validate ) + ] + , Folder "Vector" + [ ( "Applicative" , Validate ) + , ( "Functor" , Validate ) + , ( "Swizzle" , Validate ) + , ( "MixedSwizzle", Typecheck ) + ] + , Folder "VertexInput" + [ ( "CompatibleTypes" , Typecheck ) + , ( "ComponentOutOfRange" , Typecheck ) + , ( "DoubleComponents" , Typecheck ) + , ( "EquivalentComponents" , Typecheck ) + -- TODO: check that the vertex attributes are compatible with the + -- vertex shader inputs, and provide every component they consume. + --, ( "IncompatibleTypes" , Typecheck ) + --, ( "IncompatibleWidths" , Typecheck ) + --, ( "MissingComponents" , Typecheck ) + , ( "InvalidDoubleComponent", Typecheck ) + , ( "InvalidVectorComponent", Typecheck ) + -- TODO: check that the vertex attributes of a 'StructInput' + -- do not overlap. + --, ( "Overlap" , Typecheck ) + , ( "V3Double_Double" , Typecheck ) + ] + ] diff --git a/test/Tests/Array/Applicative.hs b/test/Tests/Array/Applicative.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Array/Applicative.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Array.Applicative where + +-- fir +import FIR + +------------------------------------------------ +-- program + +type Defs = '[ "arr" ':-> Input '[ Location 0 ] (Array 17 Float) + , "out" ':-> Output '[ Location 0 ] Float + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Fragment do + + arr <- get @"arr" + + let f :: Code Float -> Code Float -> Code Float + f x y = x - abs y + arr' :: Code (Array 17 Float) + arr' = f <$$> arr <**> arr + out = view @(Index 0) arr' + view @(Index 6) arr + + put @"out" out diff --git a/test/Tests/Array/ApplicativeConvert.hs b/test/Tests/Array/ApplicativeConvert.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Array/ApplicativeConvert.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Array.ApplicativeConvert where + +-- base +import Data.Maybe + ( fromJust ) + +-- vector-sized +import qualified Data.Vector.Sized as Vector + +-- fir +import FIR + +------------------------------------------------ +-- program + +-- Mapping a function over an array, with an element type for the result +-- that differs from that of the input array. + +table :: Array 4 Word32 +table = MkArray ( fromJust $ Vector.fromList [ 1, 2, 3, 4 ] ) + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "i" ':-> Word32 ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "res" ':-> Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Compute do + + i <- use @( Name "ubo" :.: Name "i" ) + + let + arr :: Code ( Array 4 Word32 ) + arr = Lit table + toFloat :: Code Word32 -> Code Float + toFloat = fromIntegral + arr' :: Code ( Array 4 Float ) + arr' = toFloat <$$> arr + + assign @( Name "out" :.: Name "res" ) + ( view @( Index 0 ) arr' + toFloat ( view @( AnIndex ( Code Word32 ) ) i arr ) ) diff --git a/test/Tests/Array/Runtime.golden b/test/Tests/Array/Runtime.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Array/Runtime.golden @@ -0,0 +1,22 @@ +test/Tests/Array/Runtime.hs:33:15: error: [GHC-64725] + • 'get'/'use': cannot focus on type + RuntimeArray Float + within binding named "storage", as it is (or contains) an opaque type. + • In a stmt of a 'do' block: + buffer <- use @(Name "storage" :.: Name "buffer") + In the third argument of ‘entryPoint’, namely + ‘do buffer <- use @(Name "storage" :.: Name "buffer") + let res :: Code Float + res = view @(AnIndex (Code Word32)) 1728 buffer + put @"out" res’ + In a stmt of a 'do' block: + entryPoint + @"main" @Fragment + do buffer <- use @(Name "storage" :.: Name "buffer") + let res :: Code Float + res = view @(AnIndex (Code Word32)) 1728 buffer + put @"out" res + | +33 | buffer <- use @( Name "storage" :.: Name "buffer" ) + | ^^^ + diff --git a/test/Tests/Array/Runtime.hs b/test/Tests/Array/Runtime.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Array/Runtime.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Array.Runtime where + +-- fir +import FIR + +------------------------------------------------ +-- program + +type Defs = '[ "storage" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "buffer" ':-> RuntimeArray Float ] ) + , "out" ':-> Output '[ Location 0 ] Float + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Fragment do + + -- Not allowed to retrieve a runtime array in this manner. + buffer <- use @( Name "storage" :.: Name "buffer" ) + + let + res :: Code Float + res = view @( AnIndex ( Code Word32 ) ) 1728 buffer + + put @"out" res diff --git a/test/Tests/Atomics/FloatBitwise.golden b/test/Tests/Atomics/FloatBitwise.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Atomics/FloatBitwise.golden @@ -0,0 +1,22 @@ +test/Tests/Atomics/FloatBitwise.hs:26:8: error: [GHC-39999] + • No instance for ‘AtomicIntegralTy Float’ + arising from a use of ‘atomicAnd’ + • In a stmt of a 'do' block: + _ <- atomicAnd + @(Name "floats" :.: Name "arr" :.: AnIndex Word32) x 1 + In the third argument of ‘entryPoint’, namely + ‘do ~(Vec3 x _ _) <- get @"gl_GlobalInvocationID" + _ <- atomicAnd + @(Name "floats" :.: Name "arr" :.: AnIndex Word32) x 1 + pure (Lit ())’ + In the second argument of ‘($)’, namely + ‘entryPoint + @"main" @Compute + do ~(Vec3 x _ _) <- get @"gl_GlobalInvocationID" + _ <- atomicAnd + @(Name "floats" :.: Name "arr" :.: AnIndex Word32) x 1 + pure (Lit ())’ + | +26 | _ <- atomicAnd @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) x 1 + | ^^^^^^^^^ + diff --git a/test/Tests/Atomics/FloatBitwise.hs b/test/Tests/Atomics/FloatBitwise.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Atomics/FloatBitwise.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Atomics.FloatBitwise where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- bitwise atomic operations are only supported on integers + +type Defs = + '[ "floats" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "arr" ':-> RuntimeArray Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 8 8 1 ] Compute + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Compute do + ~( Vec3 x _ _ ) <- get @"gl_GlobalInvocationID" + _ <- atomicAnd @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) x 1 + pure ( Lit () ) diff --git a/test/Tests/Atomics/Operations.hs b/test/Tests/Atomics/Operations.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Atomics/Operations.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Atomics.Operations where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = + '[ "floats" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "arr" ':-> RuntimeArray Float ] ) + , "words" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "count" ':-> Word32, "arr" ':-> RuntimeArray Word32 ] ) + , "ints" ':-> StorageBuffer '[ DescriptorSet 0, Binding 2 ] + ( Struct '[ "arr" ':-> RuntimeArray Int64 ] ) + , "shared" ':-> Workgroup '[] ( Array 4 Int32 ) + , "main" ':-> EntryPoint '[ LocalSize 8 8 1 ] Compute + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Compute do + + ~( Vec3 x y _ ) <- get @"gl_GlobalInvocationID" + i <- let' ( x + 64 * y ) + + -- Floating-point operations on elements of a storage buffer. + previous <- atomicAdd @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) i 0.5 + _ <- atomicMin @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) i previous + _ <- atomicMax @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) i 1 + _ <- atomicExchange @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) i 2 + f <- atomicLoad @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) i + atomicStore @( Name "floats" :.: Name "arr" :.: AnIndex Word32 ) i ( f + 1 ) + + -- Unsigned integer operations on a storage buffer member and on elements + -- of its array. + slot <- atomicAdd @( Name "words" :.: Name "count" ) 1 + _ <- atomicIncrement @( Name "words" :.: Name "count" ) + _ <- atomicDecrement @( Name "words" :.: Name "count" ) + _ <- atomicSub @( Name "words" :.: Name "count" ) 1 + _ <- atomicMin @( Name "words" :.: Name "arr" :.: AnIndex Word32 ) slot x + _ <- atomicMax @( Name "words" :.: Name "arr" :.: AnIndex Word32 ) slot y + _ <- atomicAnd @( Name "words" :.: Name "arr" :.: AnIndex Word32 ) slot 0xff + _ <- atomicOr @( Name "words" :.: Name "arr" :.: AnIndex Word32 ) slot 0x100 + _ <- atomicXor @( Name "words" :.: Name "arr" :.: AnIndex Word32 ) slot i + old <- atomicCompareExchange @( Name "words" :.: Name "arr" :.: AnIndex Word32 ) slot 0 x + + -- 64-bit signed integer operations. + _ <- atomicAdd @( Name "ints" :.: Name "arr" :.: AnIndex Word32 ) i 1 + _ <- atomicMin @( Name "ints" :.: Name "arr" :.: AnIndex Word32 ) i (-1) + + -- Signed integer operations on a workgroup variable. + _ <- atomicAdd @( Name "shared" :.: AnIndex Word32 ) 0 ( if previous > 1 then 1 else -1 ) + _ <- atomicMax @( Name "shared" :.: AnIndex Word32 ) 1 ( bitcast old ) + + pure ( Lit () ) diff --git a/test/Tests/Bits/BitCast.hs b/test/Tests/Bits/BitCast.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Bits/BitCast.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Bits.BitCast where + +-- fir +import FIR + +------------------------------------------------ +-- program + +type Defs = '[ "x" ':-> Input '[Location 0] Word32 + , "y" ':-> Input '[Location 1] Int32 + , "out" ':-> Output '[Location 0] Word32 + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Vertex do + x <- get @"x" + y <- get @"y" + -- Reinterpret between signed and unsigned integers, and floating-point numbers. + let + signed :: Code Int32 + signed = bitcast x + float :: Code Float + float = bitcast y + put @"out" ( bitcast ( signed `shiftR` ( 1 :: Code Word32 ) ) + bitcast float ) diff --git a/test/Tests/Bits/BitReverse.hs b/test/Tests/Bits/BitReverse.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Bits/BitReverse.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Bits.BitReverse where + +-- fir +import FIR + +------------------------------------------------ +-- program + +type Defs = '[ "x" ':-> Input '[Location 0] Word32 + , "out" ':-> Output '[Location 0] Word32 + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Vertex do + + x <- get @"x" + + put @"out" $ bitReverse x `xor` bitReverse ( Lit 0x80000001 ) diff --git a/test/Tests/Bits/Bits.hs b/test/Tests/Bits/Bits.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Bits/Bits.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Bits.Bits where + +-- fir +import FIR + +------------------------------------------------ +-- program + +type Defs = '[ "x" ':-> Input '[Location 0] Word32 + , "y" ':-> Input '[Location 1] Word32 + , "z" ':-> Input '[Location 2] Word32 + , "w" ':-> Input '[Location 3] Word32 + , "out" ':-> Output '[Location 0] Word32 + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Vertex do + + a <- get @"x" .&. get @"y" + + b <- def @"b" @R =<< (get @"z" .|. get @"w") + + put @"out" $ (a `shiftL` (3 :: Code Word32)) `xor` (a `shiftR` b) `xor` (complement b) diff --git a/test/Tests/Bits/ZipBits.hs b/test/Tests/Bits/ZipBits.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Bits/ZipBits.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Bits.ZipBits where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- some random boolean operations + +f :: Bool -> Bool -> Bool +f a b = a && not b + +g :: Bool -> Bool -> Bool -- g a b = not ( a || b ) +g a b = not a && ( not (f a b) `xor` b ) + +h :: Bool -> Bool -> Bool -- h a b = a +h a b = a || ( g a (f (g b a) (not a)) && a ) + +k :: Bool -> Bool -> Bool -- k a b = not ( a && b ) +k a b = h ( g a (g b (not a && b)) ) (h (b `xor` a) b) || f (not b) (a && b || h b b) + +------------------------------------------------ +-- program + +type Defs = '[ "a" ':-> Input '[Location 0] Word32 + , "b" ':-> Input '[Location 1] Word32 + , "out" ':-> Output '[Location 0] (V 4 Word32) + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Vertex do + + a <- get @"a" + b <- get @"b" + + put @"out" $ Vec4 + ( zipBits2 f a b ) -- a .&. complement b + ( zipBits2 g a b ) -- complement ( a .|. b ) + ( zipBits2 h a b ) -- a + ( zipBits2 k a b ) -- complement ( a .&. b ) diff --git a/test/Tests/Builtins/SampleId.hs b/test/Tests/Builtins/SampleId.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Builtins/SampleId.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Builtin.SampleId where + +-- fir +import FIR + +------------------------------------------------ +-- program + +type Defs = '[ "out" ':-> Output '[ Location 0 ] Float + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Fragment do + + sampleNo <- get @"gl_SampleID" + + put @"out" (fromIntegral sampleNo) diff --git a/test/Tests/Builtins/SharedBuiltin.hs b/test/Tests/Builtins/SharedBuiltin.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Builtins/SharedBuiltin.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Builtins.SharedBuiltin where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +-- Two entry points of the same module using the same built-in variable. + +type Defs = + '[ "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "res" ':-> RuntimeArray Word32 ] ) + , "main1" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + , "main2" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + entryPoint @"main1" @Compute do + ~( Vec3 x _ _ ) <- get @"gl_GlobalInvocationID" + assign @( Name "out" :.: Name "res" :.: AnIndex Word32 ) x x + + entryPoint @"main2" @Compute do + ~( Vec3 x _ _ ) <- get @"gl_GlobalInvocationID" + assign @( Name "out" :.: Name "res" :.: AnIndex Word32 ) x ( x + 1 ) diff --git a/test/Tests/Components/FloatInt.golden b/test/Tests/Components/FloatInt.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Components/FloatInt.golden @@ -0,0 +1,29 @@ +test/Tests/Components/FloatInt.hs:31:12: error: [GHC-64725] + • Incompatible scalars within Location 0: + - V 2 Float with Location 0, Component 0 requires Float, + - V 2 Int32 with Location 0, Component 2 requires Int32. + • In the second argument of ‘($)’, namely + ‘entryPoint + @"main" @Vertex + do ~(Vec2 x y) <- get @"in_col1" + ~(Vec2 z w) <- get @"in_col2" + put @"out_col" (Vec4 x y (convert z) (convert w))’ + In the expression: + Module + $ entryPoint + @"main" @Vertex + do ~(Vec2 x y) <- get @"in_col1" + ~(Vec2 z w) <- get @"in_col2" + put @"out_col" (Vec4 x y (convert z) (convert w)) + In an equation for ‘program’: + program + = Module + $ entryPoint + @"main" @Vertex + do ~(Vec2 x y) <- get @"in_col1" + ~(Vec2 z w) <- get @"in_col2" + put @"out_col" (Vec4 x y (convert z) (convert w)) + | +31 | Module $ entryPoint @"main" @Vertex do + | ^^^^^^^^^^ + diff --git a/test/Tests/Components/FloatInt.hs b/test/Tests/Components/FloatInt.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Components/FloatInt.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Components.FloatInt where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "in_col1" ':-> Input '[ Location 0 ] (V 2 Float) -- component mismatch + , "in_col2" ':-> Input '[ Location 0, Component 2 ] (V 2 Int32) -- floating-point vs integer + , "out_col" ':-> Output '[ Location 0 ] (V 4 Float) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +program :: Module Defs +program = + Module $ entryPoint @"main" @Vertex do + ~(Vec2 x y) <- get @"in_col1" + ~(Vec2 z w) <- get @"in_col2" + put @"out_col" ( Vec4 x y (convert z) (convert w) ) diff --git a/test/Tests/Components/FloatWidth.golden b/test/Tests/Components/FloatWidth.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Components/FloatWidth.golden @@ -0,0 +1,29 @@ +test/Tests/Components/FloatWidth.hs:31:12: error: [GHC-64725] + • Incompatible scalars within Location 0: + - V 2 Float with Location 0, Component 0 requires Float, + - Double with Location 0, Component 2 requires Double. + • In the second argument of ‘($)’, namely + ‘entryPoint + @"main" @Vertex + do ~(Vec2 x y) <- get @"in_col1" + z <- get @"in_col2" + put @"out_col" (Vec4 x y (convert z) 1)’ + In the expression: + Module + $ entryPoint + @"main" @Vertex + do ~(Vec2 x y) <- get @"in_col1" + z <- get @"in_col2" + put @"out_col" (Vec4 x y (convert z) 1) + In an equation for ‘program’: + program + = Module + $ entryPoint + @"main" @Vertex + do ~(Vec2 x y) <- get @"in_col1" + z <- get @"in_col2" + put @"out_col" (Vec4 x y (convert z) 1) + | +31 | Module $ entryPoint @"main" @Vertex do + | ^^^^^^^^^^ + diff --git a/test/Tests/Components/FloatWidth.hs b/test/Tests/Components/FloatWidth.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Components/FloatWidth.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Components.FloatWidth where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "in_col1" ':-> Input '[ Location 0 ] (V 2 Float) -- component mismatch + , "in_col2" ':-> Input '[ Location 0, Component 2 ] Double -- floating-point types of different widths + , "out_col" ':-> Output '[ Location 0 ] (V 4 Float) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +program :: Module Defs +program = + Module $ entryPoint @"main" @Vertex do + ~(Vec2 x y) <- get @"in_col1" + z <- get @"in_col2" + put @"out_col" ( Vec4 x y (convert z) 1 ) diff --git a/test/Tests/Components/IntWidth.golden b/test/Tests/Components/IntWidth.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Components/IntWidth.golden @@ -0,0 +1,29 @@ +test/Tests/Components/IntWidth.hs:31:12: error: [GHC-64725] + • Incompatible scalars within Location 0: + - V 2 Word32 with Location 0, Component 0 requires Word32, + - Word64 with Location 0, Component 2 requires Word64. + • In the second argument of ‘($)’, namely + ‘entryPoint + @"main" @Vertex + do ~(Vec2 x y) <- get @"in_col1" + z <- get @"in_col2" + put @"out_col" (Vec4 x y (convert z) 1)’ + In the expression: + Module + $ entryPoint + @"main" @Vertex + do ~(Vec2 x y) <- get @"in_col1" + z <- get @"in_col2" + put @"out_col" (Vec4 x y (convert z) 1) + In an equation for ‘program’: + program + = Module + $ entryPoint + @"main" @Vertex + do ~(Vec2 x y) <- get @"in_col1" + z <- get @"in_col2" + put @"out_col" (Vec4 x y (convert z) 1) + | +31 | Module $ entryPoint @"main" @Vertex do + | ^^^^^^^^^^ + diff --git a/test/Tests/Components/IntWidth.hs b/test/Tests/Components/IntWidth.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Components/IntWidth.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Components.IntWidth where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "in_col1" ':-> Input '[ Location 0 ] (V 2 Word32) -- component mismatch + , "in_col2" ':-> Input '[ Location 0, Component 2 ] Word64 -- integer types of different widths + , "out_col" ':-> Output '[ Location 0 ] (V 4 Word32) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +program :: Module Defs +program = + Module $ entryPoint @"main" @Vertex do + ~(Vec2 x y) <- get @"in_col1" + z <- get @"in_col2" + put @"out_col" ( Vec4 x y (convert z) 1 ) diff --git a/test/Tests/Components/Sign.hs b/test/Tests/Components/Sign.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Components/Sign.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Components.Sign where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "in_col1" ':-> Input '[ Location 0 ] (V 2 Int32 ) -- valid component assignment + , "in_col2" ':-> Input '[ Location 0, Component 2 ] (V 2 Word32) -- (signedness is not important) + , "out_col" ':-> Output '[ Location 0 ] (V 4 Int32 ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +program :: Module Defs +program = + Module $ entryPoint @"main" @Vertex do + ~(Vec2 x y) <- get @"in_col1" + ~(Vec2 z w) <- get @"in_col2" + put @"out_col" ( Vec4 x y (convert z) (convert w) ) diff --git a/test/Tests/Control/BreakContinueNested.hs b/test/Tests/Control/BreakContinueNested.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/BreakContinueNested.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.BreakContinueNested where + +-- fir +import FIR + +------------------------------------------------ +-- program + +-- Early exits out of several loops at once, from the innermost of three nested loops: +-- - 'break @3' exits all three loops, +-- - 'breakContinue @2' continues the outermost loop, +-- - 'breakContinue @1' continues the middle loop. +-- +-- In structured control flow, these must exit the innermost loop first, +-- and continue the early exit from its merge block. + +type Defs = + '[ "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "res" ':-> Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Compute do + + _ <- def @"x" @RW @Float 0 + _ <- def @"i" @RW @Word32 0 + while ( ( < 10 ) <<$>> get @"i" ) do + modify @"i" ( + 1 ) + loop do + modify @"x" ( * 2 ) + loop do + modify @"x" ( + 1 ) + x <- get @"x" + if x > 100 + then do + put @"x" ( -1 ) + break @3 + else + if x > 50 + then breakContinue @2 + else + if x > 20 + then breakContinue @1 + else continue + + x <- get @"x" + i <- get @"i" + assign @( Name "out" :.: Name "res" ) ( x + fromIntegral i ) diff --git a/test/Tests/Control/BreakInCondition.hs b/test/Tests/Control/BreakInCondition.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/BreakInCondition.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.BreakInCondition where + +-- fir +import FIR + +------------------------------------------------ +-- program + +-- Early exits from the condition of a loop, which refer to the enclosing loops. + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "n" ':-> Word32 ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "res" ':-> Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Compute do + + n <- use @( Name "ubo" :.: Name "n" ) + _ <- def @"x" @RW @Word32 0 + _ <- def @"y" @RW @Word32 0 + + -- 'break' and 'continue' in the condition of an inner loop. + loop do + modify @"x" ( + 1 ) + while + ( do + x <- get @"x" + when ( x > 100 ) ( break @1 ) + when ( x > 50 ) continue + pure ( x < n ) + ) do + modify @"x" ( + 2 ) + + -- A loop in the condition of a loop, breaking out of both the inner loop + -- and the loop enclosing the outer loop's condition. + loop do + modify @"y" ( + 1 ) + while + ( do + loop do + y <- get @"y" + when ( y > 100 ) ( break @2 ) + when ( y > 10 ) ( break @1 ) + put @"y" ( y * 2 ) + y <- get @"y" + pure ( y < n ) + ) do + modify @"y" ( + 3 ) + + x <- get @"x" + y <- get @"y" + assign @( Name "out" :.: Name "res" ) ( fromIntegral ( x + y ) ) diff --git a/test/Tests/Control/BreakNested.hs b/test/Tests/Control/BreakNested.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/BreakNested.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.BreakNested where + +-- fir +import FIR + +------------------------------------------------ +-- program + +-- Breaking out of two loops at once: the break is a predecessor of the merge block +-- of the outer loop, and must contribute to its ϕ-instructions (here, for "x"). + +type Defs = + '[ "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "res" ':-> Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Compute do + + _ <- def @"x" @RW @Float 0 + loop do + modify @"x" ( + 1 ) + loop do + x <- get @"x" + if x > 10 + then do + put @"x" 100 + break @2 + else + if x > 5 + then break @1 + else put @"x" ( x + 2 ) + + x <- get @"x" + assign @( Name "out" :.: Name "res" ) x diff --git a/test/Tests/Control/DeadCode.hs b/test/Tests/Control/DeadCode.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/DeadCode.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.DeadCode where + +-- fir +import FIR + +------------------------------------------------ +-- program + +-- Code following a 'break' is unreachable. It must not be emitted into the block +-- that the 'break' terminated, and control flow constructs within it must still be +-- emitted consistently (e.g. a selection whose merge block is missing is invalid). + +type Defs = + '[ "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "res" ':-> Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Compute do + + _ <- def @"x" @RW @Float 0 + + -- Conditional in dead code after a break. + loop do + x <- get @"x" + if x > 3 + then do + break @1 + if x > 4 + then put @"x" 1 + else put @"x" 2 + else put @"x" ( x + 1 ) + + -- Loop body ending with a break. + while ( ( < 10 ) <<$>> get @"x" ) do + modify @"x" ( * 2 ) + break @1 + + x <- get @"x" + assign @( Name "out" :.: Name "res" ) x diff --git a/test/Tests/Control/Def.hs b/test/Tests/Control/Def.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/Def.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.Def where + +-- fir +import FIR +import FIR.Syntax.Labels +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = '[ "position" ':-> Output '[Location 0] (V 4 Float) + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Vertex do + + let (#<) = (<) @(Program _i _i _) -- disambiguate to help type inference + + #t @Float #= 0 + #s @Float #= 1 + #r @Float #= 1 + + while ( #t #< abs ( #s - #t ) ) do + t <- #t + s <- #s + + #r .= t + s + + r <- #r + + if r < 1 + then #r .= 1 + else #r .= r - 1 + + #u @Float #= 0 -- variable definition not in top block after function declaration + + #position .= Vec4 r r r 1 diff --git a/test/Tests/Control/Loop1.hs b/test/Tests/Control/Loop1.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/Loop1.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.Loop1 where + +-- fir +import FIR +import FIR.Syntax.Labels + +------------------------------------------------ +-- program + +type Defs = '[ "main" ':-> EntryPoint '[] Vertex ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Vertex do + + let (#<) = (<) @(Program _i _i _) -- disambiguate to help type inference + + #t @Float #= 0 + #s @Float #= 1 + #r @Float #= 1 + + while ( #t #< abs ( #s - #t ) ) do + t <- #t + s <- #s + #t %= (+1) + #s .= (s+2*t) + #r .= t + s + while ( #r #< ( #t * ( #s + #t ) ) ) do + #r %= (+1) + + r <- #r + s <- #s + t <- #t + + #gl_Position .= Vec4 r s t 1 diff --git a/test/Tests/Control/Loop2.hs b/test/Tests/Control/Loop2.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/Loop2.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.Loop2 where + +-- fir +import FIR +import FIR.Syntax.Labels +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = '[ "main" ':-> EntryPoint '[] Vertex ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Vertex do + + #p #= ( 99 :: Code Float ) + #q #= ( Vec4 3 4 5 6 :: Code ( V 4 Float ) ) + + loop do + p <- #p + q <- #q + if p * norm q > 1555 + then break @1 + else do + #p .= p + 17 + #q .= 3 *^ q + + q <- #q + + #gl_Position .= q diff --git a/test/Tests/Control/Loop3.hs b/test/Tests/Control/Loop3.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/Loop3.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + + +module Tests.Control.Loop3 where + +-- fir +import FIR +import FIR.Syntax.Labels + +------------------------------------------------ +-- program + +type Defs = '[ "main" ':-> EntryPoint '[] Vertex ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Vertex do + + #i #= (1 :: Code Int32) + #v #= (1728 :: Code Float) + + loop do + i <- #i + + when (i > 32) do + #v .= 123 + break @1 + + when (i * 2 > 16) do + #v .= 456 + break @1 + + #i %= (+1) + + v <- #v + + #gl_Position .= Vec4 v v v 1 diff --git a/test/Tests/Control/LoopCondition.hs b/test/Tests/Control/LoopCondition.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/LoopCondition.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.LoopCondition where + +-- fir +import FIR + +------------------------------------------------ +-- program + +-- A loop condition containing control flow, which modifies a binding. + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "n" ':-> Word32 ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "res" ':-> Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Compute do + + n <- use @( Name "ubo" :.: Name "n" ) + _ <- def @"x" @RW @Word32 0 + _ <- def @"y" @RW @Float 0 + while + ( do + x <- get @"x" + if x > 3 + then do + modify @"y" ( + 1 ) + pure ( x < n ) + else pure ( x < 2 * n ) + ) do + modify @"x" ( + 1 ) + + y <- get @"y" + assign @( Name "out" :.: Name "res" ) y diff --git a/test/Tests/Control/LoopsNested.hs b/test/Tests/Control/LoopsNested.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/LoopsNested.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.LoopsNested where + +-- fir +import FIR + +------------------------------------------------ +-- program + +-- Nested loops in a function, with bindings that are: +-- - modified in the inner loop ("acc", "m"), +-- - modified in the outer loop only ("j"), +-- - never modified ("k"), +-- - only modified just before breaking out of the outer loop ("b"). + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "n" ':-> Word32 ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "res" ':-> Float ] ) + , "f" ':-> Function '[ "u" ':-> Var R Word32 ] Float + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + ( f :: Code Word32 -> Code Float ) <- fundef @"f" do + _ <- def @"acc" @RW @Float 0 + _ <- def @"j" @RW @Word32 0 + _ <- def @"m" @RW @Word32 0 + _ <- def @"k" @RW @Float 3 + _ <- def @"b" @RW @Float 0 + u <- get @"u" + while ( ( < u ) <<$>> get @"j" ) do + j <- get @"j" + put @"m" 0 + while ( ( < j ) <<$>> get @"m" ) do + m <- get @"m" + k <- get @"k" + modify @"acc" ( + ( fromIntegral m * k ) ) + put @"m" ( m + 1 ) + acc <- get @"acc" + if acc > 100 + then do + put @"b" acc + break @1 + else put @"j" ( j + 1 ) + acc <- get @"acc" + b <- get @"b" + k <- get @"k" + pure ( acc + b + k ) + + entryPoint @"main" @Compute do + n <- use @( Name "ubo" :.: Name "n" ) + assign @( Name "out" :.: Name "res" ) ( f n ) diff --git a/test/Tests/Control/RayQueryVariable.hs b/test/Tests/Control/RayQueryVariable.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/RayQueryVariable.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.RayQueryVariable where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +-- Initialising a ray query declares a variable holding the ray query object, +-- which must be declared in a valid location (module scope for a Private variable, +-- first block of the function for a Function variable). + +type Defs = + '[ "accel" ':-> UniformConstant '[ DescriptorSet 0, Binding 0 ] AccelerationStructure + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Compute do + accel <- get @"accel" + locally do + initialize @"query" accel + ( RayInfo + { rayFlags = 0 + , rayOrigin = Vec3 0 0 0 + , rayDirection = Vec3 0 0 1 + , rayTMin = 0 + , rayTMax = 100 + , cullMask = 0xff + } + ) + terminate @"query" diff --git a/test/Tests/Control/Selection.hs b/test/Tests/Control/Selection.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/Selection.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.Selection where + +-- fir +import FIR + +------------------------------------------------ +-- program + +type Defs = '[ "x" ':-> Input '[Location 0] Float + , "y" ':-> Input '[Location 1] Float + , "out" ':-> Output '[Location 0] Float + , "main" ':-> EntryPoint '[OriginUpperLeft] Fragment + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Fragment do + + -- test "selection" instruction + x <- get @"x" + x' <- def @"x'" @R @Float ( if x < 0 then 0 else 3*x ) + + -- test monadic "if-then-else" instruction + y <- get @"y" + _ <- def @"y'" @RW @Float y + if y < 0 + then do + put @"y'" (y+7) + else do + put @"y'" 4 + y' <- get @"y'" + + + put @"out" (x'+y') diff --git a/test/Tests/Control/Switch.hs b/test/Tests/Control/Switch.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/Switch.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.Switch where + +-- fir +import FIR + +------------------------------------------------ +-- program + +type Defs = '[ "a" ':-> Input '[Location 0, Flat] Word32 + , "b" ':-> Input '[Location 1, Flat] Int32 + , "t" ':-> Input '[Location 2] Float + , "out" ':-> Output '[Location 0] Float + , "main" ':-> EntryPoint '[OriginUpperLeft] Fragment + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Fragment do + + -- test "switch" instruction + a <- get @"a" + t <- get @"t" + x <- def @"x" @R @Float $ + switch a + [ 7 :-> t + 1 + , 2 :-> 2 + , 1 :-> 3 - t + ] + ( t - 9 ) -- default + + -- test monadic "switchM" instruction + y <- switchM (get @"b") + [ 2 :-> pure 11 + , 1 :-> get @"t" + ] + ( abs $ get @"t" ) + + put @"out" (x + y) diff --git a/test/Tests/Control/TemporaryBranches.hs b/test/Tests/Control/TemporaryBranches.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/TemporaryBranches.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.TemporaryBranches where + +-- base +import Data.Maybe + ( fromJust ) + +-- vector-sized +import qualified Data.Vector.Sized as Vector + +-- fir +import FIR + +------------------------------------------------ +-- program + +-- Indexing into an array value with a run-time index requires copying the array +-- into a local variable. The copy made in one branch must not be reused +-- in the other branch, nor after the branches merge, as the store that +-- initialises the local variable does not dominate those uses. + +table :: Array 4 Float +table = MkArray ( fromJust $ Vector.fromList [ 1, 2, 3, 4 ] ) + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "i" ':-> Word32 ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "res" ':-> Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Compute do + + let + arr :: Code ( Array 4 Float ) + arr = Lit table + i <- use @( Name "ubo" :.: Name "i" ) + + r <- + if i > 2 + then pure ( view @( AnIndex ( Code Word32 ) ) i arr ) + else pure ( view @( AnIndex ( Code Word32 ) ) ( i - 1 ) arr ) + + assign @( Name "out" :.: Name "res" ) ( r + view @( AnIndex ( Code Word32 ) ) ( i + 1 ) arr ) diff --git a/test/Tests/Control/TemporaryFunctions.hs b/test/Tests/Control/TemporaryFunctions.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/TemporaryFunctions.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.TemporaryFunctions where + +-- base +import Data.Maybe + ( fromJust ) + +-- vector-sized +import qualified Data.Vector.Sized as Vector + +-- fir +import FIR + +------------------------------------------------ +-- program + +-- Indexing a constant array with a run-time index requires a local variable +-- holding the array. Each function must use its own local variable. + +table :: Array 4 Float +table = MkArray ( fromJust $ Vector.fromList [ 1, 2, 3, 4 ] ) + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "i" ':-> Word32 ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "res" ':-> Float ] ) + , "f" ':-> Function '[ "u" ':-> Var R Word32 ] Float + , "g" ':-> Function '[ "v" ':-> Var R Word32 ] Float + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + ( f :: Code Word32 -> Code Float ) <- fundef @"f" do + u <- get @"u" + pure ( view @( AnIndex ( Code Word32 ) ) u ( Lit table :: Code ( Array 4 Float ) ) ) + + ( g :: Code Word32 -> Code Float ) <- fundef @"g" do + v <- get @"v" + pure ( view @( AnIndex ( Code Word32 ) ) ( v + 1 ) ( Lit table :: Code ( Array 4 Float ) ) ) + + entryPoint @"main" @Compute do + i <- use @( Name "ubo" :.: Name "i" ) + assign @( Name "out" :.: Name "res" ) ( f i + g i ) diff --git a/test/Tests/Control/TemporaryLoop.hs b/test/Tests/Control/TemporaryLoop.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/TemporaryLoop.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.TemporaryLoop where + +-- base +import Data.Maybe + ( fromJust ) + +-- vector-sized +import qualified Data.Vector.Sized as Vector + +-- fir +import FIR + +------------------------------------------------ +-- program + +-- A local copy of an array made inside a loop body (in order to index it +-- with a run-time index) must not be reused after the loop: +-- the loop body might not run at all. + +table :: Array 4 Float +table = MkArray ( fromJust $ Vector.fromList [ 1, 2, 3, 4 ] ) + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "n" ':-> Word32 ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "res" ':-> Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Compute do + + let + arr :: Code ( Array 4 Float ) + arr = Lit table + n <- use @( Name "ubo" :.: Name "n" ) + + _ <- def @"i" @RW @Word32 0 + _ <- def @"acc" @RW @Float 0 + while ( ( < n ) <<$>> get @"i" ) do + i <- get @"i" + modify @"acc" ( + view @( AnIndex ( Code Word32 ) ) i arr ) + put @"i" ( i + 1 ) + + acc <- get @"acc" + assign @( Name "out" :.: Name "res" ) ( acc + view @( AnIndex ( Code Word32 ) ) n arr ) diff --git a/test/Tests/Control/TemporarySetter.hs b/test/Tests/Control/TemporarySetter.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Control/TemporarySetter.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Control.TemporarySetter where + +-- base +import Data.Maybe + ( fromJust ) + +-- vector-sized +import qualified Data.Vector.Sized as Vector + +-- fir +import FIR + +------------------------------------------------ +-- program + +-- Setting an element of an array value at a run-time index goes through a local copy +-- of the array. Indexing the original array afterwards must not read the modified copy. + +table :: Array 4 Float +table = MkArray ( fromJust $ Vector.fromList [ 1, 2, 3, 4 ] ) + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "i" ':-> Word32 ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "res" ':-> Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Compute do + + let + arr :: Code ( Array 4 Float ) + arr = Lit table + i <- use @( Name "ubo" :.: Name "i" ) + + new <- let' $ view @( AnIndex ( Code Word32 ) ) i ( set @( AnIndex ( Code Word32 ) ) i 7 arr ) + old <- let' $ view @( AnIndex ( Code Word32 ) ) i arr + + assign @( Name "out" :.: Name "res" ) ( new + old ) diff --git a/test/Tests/Debug/Printf.hs b/test/Tests/Debug/Printf.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Debug/Printf.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Debug.Printf where + +-- fir +import FIR +import FIR.Syntax.DebugPrintf +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = '[ "position" ':-> Input '[Location 0] (V 4 Float) + , "colour" ':-> Input '[Location 1, Flat] (V 4 Word32) + , "out" ':-> Output '[Location 0] (V 4 Word32) + , "main" ':-> EntryPoint '[OriginUpperLeft] Fragment + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Fragment do + + pos <- get @"position" + col <- get @"colour" + + debugPrintf ( "position = " % vec @4 float % " colour = " % vec @4 word32Hex ) pos col + + put @"out" col diff --git a/test/Tests/Definitions/Descriptors.golden b/test/Tests/Definitions/Descriptors.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Definitions/Descriptors.golden @@ -0,0 +1,21 @@ +test/Tests/Definitions/Descriptors.hs:28:11: error: [GHC-64725] + • More than one descriptor with DescriptorSet 1 and Binding 2: + ["desc3", "desc2", "desc1"] + • In the expression: + Module + do entryPoint + @"main" @Vertex + do xy <- use @(Name "desc1" :.: Name "v") + abcd <- imageRead @"desc2" xy + .... + In an equation for ‘program’: + program + = Module + do entryPoint + @"main" @Vertex + do xy <- use @(Name "desc1" :.: Name "v") + .... + | +28 | program = Module do + | ^^^^^^ + diff --git a/test/Tests/Definitions/Descriptors.hs b/test/Tests/Definitions/Descriptors.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Definitions/Descriptors.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Definitions.Descriptors where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = '[ "desc1" ':-> Uniform '[ DescriptorSet 1, Binding 2 ] + ( Struct '[ "v" ':-> V 2 Word32 ] ) + , "desc2" ':-> Image2D '[ DescriptorSet 1, Binding 2 ] ( RGBA8 UNorm ) + , "desc3" ':-> StorageBuffer '[ DescriptorSet 1, Binding 2 ] + ( Struct '[ "rt" ':-> RuntimeArray ( V 4 Float ) ] ) + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Vertex do + + xy <- use @( Name "desc1" :.: Name "v" ) + abcd <- imageRead @"desc2" xy + assign @( Name "desc3" :.: Name "rt" :.: AnIndex Word32 ) 17 abcd diff --git a/test/Tests/Definitions/OriginLowerLeft.golden b/test/Tests/Definitions/OriginLowerLeft.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Definitions/OriginLowerLeft.golden @@ -0,0 +1,80 @@ +test/Tests/Definitions/OriginLowerLeft.hs:24:3: error: [GHC-64725] + • Fragment shader named "main" uses execution mode OriginLowerLeft, which Vulkan does not allow. + Use OriginUpperLeft instead. + • In a stmt of a 'do' block: + entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1) + In the first argument of ‘Module’, namely + ‘do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)’ + In the expression: + Module + do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1) + | +24 | entryPoint @"main" @Fragment do + | ^^^^^^^^^^ + +test/Tests/Definitions/OriginLowerLeft.hs:24:3: error: [GHC-64725] + • Fragment shader named "main" uses execution mode OriginLowerLeft, which Vulkan does not allow. + Use OriginUpperLeft instead. + • In a stmt of a 'do' block: + entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1) + In the first argument of ‘Module’, namely + ‘do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)’ + In the expression: + Module + do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1) + | +24 | entryPoint @"main" @Fragment do + | ^^^^^^^^^^ + +test/Tests/Definitions/OriginLowerLeft.hs:24:3: error: [GHC-64725] + • Fragment shader named "main" uses execution mode OriginLowerLeft, which Vulkan does not allow. + Use OriginUpperLeft instead. + • In a stmt of a 'do' block: + entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1) + In the first argument of ‘Module’, namely + ‘do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)’ + In the expression: + Module + do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1) + | +24 | entryPoint @"main" @Fragment do + | ^^^^^^^^^^ + +test/Tests/Definitions/OriginLowerLeft.hs:24:3: error: [GHC-64725] + • Fragment shader named "main" uses execution mode OriginLowerLeft, which Vulkan does not allow. + Use OriginUpperLeft instead. + • In a stmt of a 'do' block: + entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1) + In the first argument of ‘Module’, namely + ‘do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1)’ + In the expression: + Module + do entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1) + | +24 | entryPoint @"main" @Fragment do + | ^^^^^^^^^^ + +test/Tests/Definitions/OriginLowerLeft.hs:25:5: error: [GHC-64725] + • Fragment shader named "main" uses execution mode OriginLowerLeft, which Vulkan does not allow. + Use OriginUpperLeft instead. + • In a stmt of a 'do' block: put @"out_col" (Vec4 0 0 0 1) + In the third argument of ‘entryPoint’, namely + ‘do put @"out_col" (Vec4 0 0 0 1)’ + In a stmt of a 'do' block: + entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1) + | +25 | put @"out_col" ( Vec4 0 0 0 1 ) + | ^^^ + +test/Tests/Definitions/OriginLowerLeft.hs:25:5: error: [GHC-64725] + • Fragment shader named "main" uses execution mode OriginLowerLeft, which Vulkan does not allow. + Use OriginUpperLeft instead. + • In a stmt of a 'do' block: put @"out_col" (Vec4 0 0 0 1) + In the third argument of ‘entryPoint’, namely + ‘do put @"out_col" (Vec4 0 0 0 1)’ + In a stmt of a 'do' block: + entryPoint @"main" @Fragment do put @"out_col" (Vec4 0 0 0 1) + | +25 | put @"out_col" ( Vec4 0 0 0 1 ) + | ^^^ + diff --git a/test/Tests/Definitions/OriginLowerLeft.hs b/test/Tests/Definitions/OriginLowerLeft.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Definitions/OriginLowerLeft.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Definitions.OriginLowerLeft where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- Vulkan does not allow fragment shaders with a lower-left origin + +type Defs = + '[ "out_col" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginLowerLeft ] Fragment + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Fragment do + put @"out_col" ( Vec4 0 0 0 1 ) diff --git a/test/Tests/Definitions/PushConstant.golden b/test/Tests/Definitions/PushConstant.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Definitions/PushConstant.golden @@ -0,0 +1,16 @@ +test/Tests/Definitions/PushConstant.hs:23:11: error: [GHC-64725] + • Push constant named "pc" should be backed by a struct; + found type Float instead. + • In the expression: + Module + do entryPoint + @"main" @Compute do assign @(Name "out" :.: Name "f") =<< get @"pc" + In an equation for ‘program’: + program + = Module + do entryPoint + @"main" @Compute do assign @(Name "out" :.: Name "f") =<< get @"pc" + | +23 | program = Module do + | ^^^^^^ + diff --git a/test/Tests/Definitions/PushConstant.hs b/test/Tests/Definitions/PushConstant.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Definitions/PushConstant.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Definitions.PushConstant where + +-- fir +import FIR + +------------------------------------------------ +-- push constants must be structures + +type Defs = + '[ "pc" ':-> PushConstant '[] Float + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] ( Struct '[ "f" ':-> Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + assign @( Name "out" :.: Name "f" ) =<< get @"pc" diff --git a/test/Tests/Definitions/UniformRuntimeArray.golden b/test/Tests/Definitions/UniformRuntimeArray.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Definitions/UniformRuntimeArray.golden @@ -0,0 +1,21 @@ +test/Tests/Definitions/UniformRuntimeArray.hs:24:11: error: [GHC-64725] + • Structure member "rt" cannot appear in buffer named "ubo". + Its type RuntimeArray Float + is opaque (or it contains an opaque type). + • In the expression: + Module + do entryPoint + @"main" @Compute + do assign @(Name "out" :.: Name "f") + =<< use @(Name "ubo" :.: Name "x") + In an equation for ‘program’: + program + = Module + do entryPoint + @"main" @Compute + do assign @(Name "out" :.: Name "f") + =<< use @(Name "ubo" :.: Name "x") + | +24 | program = Module do + | ^^^^^^ + diff --git a/test/Tests/Definitions/UniformRuntimeArray.hs b/test/Tests/Definitions/UniformRuntimeArray.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Definitions/UniformRuntimeArray.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Definitions.UniformRuntimeArray where + +-- fir +import FIR + +------------------------------------------------ +-- uniform buffers can't contain runtime arrays + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "x" ':-> Float, "rt" ':-> RuntimeArray Float ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] ( Struct '[ "f" ':-> Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + assign @( Name "out" :.: Name "f" ) =<< use @( Name "ubo" :.: Name "x" ) diff --git a/test/Tests/Geometry/Geometry.hs b/test/Tests/Geometry/Geometry.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Geometry/Geometry.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Geometry.Geometry where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type GeometryDefs = + '[ "in_color" ':-> Input '[ Location 0 ] ( Array 3 (V 4 Float ) ) + , "out_color" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "normal" ':-> Output '[ Location 1 ] ( V 3 Float ) + , "main" ':-> EntryPoint + '[ Triangles + , OutputTriangleStrip + , OutputVertices 3 + , Invocations 1 + ] + Geometry + ] + +program :: Module GeometryDefs +program = Module $ entryPoint @"main" @Geometry do + v0 <- use @(Name "gl_in" :.: Index 0 :.: Name "gl_Position") + v1 <- use @(Name "gl_in" :.: Index 1 :.: Name "gl_Position") + v2 <- use @(Name "gl_in" :.: Index 2 :.: Name "gl_Position") + let + Vec4 u1x u1y u1z _ = v1 ^-^ v0 + Vec4 u2x u2y u2z _ = v2 ^-^ v0 + normal = normalise ( Vec3 u1x u1y u1z `cross` Vec3 u2x u2y u2z ) + color <- get @"in_color" + + put @"normal" normal + put @"gl_Position" v0 + put @"out_color" ( view @(Index 0) color ) + emitVertex + + put @"normal" normal + put @"gl_Position" v1 + put @"out_color" ( view @(Index 1) color ) + emitVertex + + put @"normal" normal + put @"gl_Position" v2 + put @"out_color" ( view @(Index 2) color ) + emitVertex + endPrimitive + + pure ( Lit () ) diff --git a/test/Tests/Geometry/NotGeometry.golden b/test/Tests/Geometry/NotGeometry.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Geometry/NotGeometry.golden @@ -0,0 +1,18 @@ +test/Tests/Geometry/NotGeometry.hs:34:5: error: [GHC-18872] + • Couldn't match type ‘FragmentShader’ with ‘GeometryShader’ + arising from a use of ‘emitVertex’ + • In a stmt of a 'do' block: emitVertex + In the third argument of ‘entryPoint’, namely + ‘do col <- get @"in_colour" + put @"out_colour" col + emitVertex’ + In a stmt of a 'do' block: + entryPoint + @"main" @Fragment + do col <- get @"in_colour" + put @"out_colour" col + emitVertex + | +34 | emitVertex -- not allowed: not in a geometry shader + | ^^^^^^^^^^ + diff --git a/test/Tests/Geometry/NotGeometry.hs b/test/Tests/Geometry/NotGeometry.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Geometry/NotGeometry.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Geometry.NotGeometry where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type FragmentDefs = + '[ "in_position" ':-> Input '[ Location 0 ] (V 4 Float) + , "in_colour" ':-> Input '[ Location 1 ] (V 4 Float) + , "out_colour" ':-> Output '[ Location 0 ] (V 4 Float) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +program :: Module FragmentDefs +program = Module do + entryPoint @"main" @Fragment do + col <- get @"in_colour" + put @"out_colour" col + emitVertex -- not allowed: not in a geometry shader diff --git a/test/Tests/Groups/GroupAdd.hs b/test/Tests/Groups/GroupAdd.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Groups/GroupAdd.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Groups.GroupAdd where + +-- fir +import FIR +import Math.Linear + + +------------------------------------------------ +-- program + +type Defs = + '[ "img" ':-> Image2D '[ DescriptorSet 0, Binding 1 ] + ( RGBA8 UNorm ) + , "main" ':-> EntryPoint '[ LocalSize 16 8 1 ] + Compute + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Compute do + + ~(Vec3 i_x i_y _) <- get @"gl_GlobalInvocationID" + gl_SubgroupInvocationID <- get @"gl_SubgroupInvocationID" + + someSubgroupOutput <- groupAdd @Subgroup @Reduce (Vec2 i_x i_y) + + imageWrite @"img" + someSubgroupOutput + (Vec4 0 0 0 0) + diff --git a/test/Tests/Images/Gather.hs b/test/Tests/Images/Gather.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Images/Gather.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Images.Gather where + +-- base +import Data.Maybe + ( fromJust ) + +-- fir +import FIR +import Math.Linear + +-- vector-sized +import qualified Data.Vector.Sized as Vector + +------------------------------------------------ +-- program + +type Defs + = '[ "image" ':-> Texture2D '[ Binding 0, DescriptorSet 0 ] (RGBA8 UNorm) + , "in_pos" ':-> Input '[ Location 0 ] (V 2 Float) + , "out_col" ':-> Output '[ Location 0 ] (V 4 Float) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +program :: Module Defs +program = + Module $ entryPoint @"main" @Fragment do + pos <- get @"in_pos" + let offsetArray :: Array 4 (V 2 Int32) + offsetArray = MkArray (fromJust $ Vector.fromList [V2 0 0, V2 0 1, V2 1 0, V2 1 1]) + col <- use @(ImageTexel "image") (Gather (ComponentWithOffsets 0 offsetArray) NilOps) pos + put @"out_col" col diff --git a/test/Tests/Images/ReadWrite.hs b/test/Tests/Images/ReadWrite.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Images/ReadWrite.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Images.ReadWrite where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "image1" ':-> Image2D '[ Binding 0, DescriptorSet 0 ] (RG32 UI) + , "image2" ':-> Image2D '[ Binding 0, DescriptorSet 1 ] (R32 F) + , "out_col" ':-> Output '[ Location 0 ] (V 4 Float) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Fragment do + ( index2D :: Code ( V 2 Word32 ) ) <- + let' =<< imageRead @"image1" ( Vec2 ( 0 :: Code Word32 ) ( 1 :: Code Word32 ) ) + ( float :: Code Float ) <- + let' =<< imageRead @"image2" index2D + imageWrite @"image2" index2D ( 2 * float ) + put @"out_col" ( Vec4 float float float float ) diff --git a/test/Tests/Images/Sample.hs b/test/Tests/Images/Sample.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Images/Sample.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Images.Sample where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "image" ':-> Texture2D '[ Binding 0, DescriptorSet 0 ] (RGBA8 UNorm) + , "in_pos" ':-> Input '[ Location 0 ] (V 2 Float) + , "out_col" ':-> Output '[ Location 0 ] (V 4 Float) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +program :: Module Defs +program = + Module $ entryPoint @"main" @Fragment do + pos <- get @"in_pos" + col <- use @(ImageTexel "image") (MinLOD ( 0.5 :: Code Float ) NilOps) pos + put @"out_col" col diff --git a/test/Tests/Inference/Ising1.golden b/test/Tests/Inference/Ising1.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Inference/Ising1.golden @@ -0,0 +1,1 @@ +No type-checking errors. diff --git a/test/Tests/Inference/Ising1.hs b/test/Tests/Inference/Ising1.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Inference/Ising1.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Inference.Ising1 where + +-- fir +import FIR + +------------------------------------------------ + +data Parity = Even | Odd +data SParity ( parity :: Parity ) where + SEven :: SParity Even + SOdd :: SParity Odd + +type family Bd ( parity :: Parity ) = r | r -> parity where + Bd Even = 2 + Bd Odd = 3 + +type Defs ( parity :: Parity ) = + '[ "out" ':-> Image2D '[ DescriptorSet 0, Binding 37 ] ( R32 F ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +shader :: _ => SParity parity -> Module ( Defs parity ) +shader sParity = Module $ entryPoint @"main" @Compute $ do + val <- foo + pure ( Lit () ) + +foo :: Program _s _t ( Code Float ) +foo = def @"x" @R @Float 3 diff --git a/test/Tests/Inference/Ising2.golden b/test/Tests/Inference/Ising2.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Inference/Ising2.golden @@ -0,0 +1,1 @@ +No type-checking errors. diff --git a/test/Tests/Inference/Ising2.hs b/test/Tests/Inference/Ising2.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Inference/Ising2.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Inference.Ising2 where + +-- fir +import FIR + +------------------------------------------------ +-- Work sizes. + +data Parity = Even | Odd +data SParity ( parity :: Parity ) where + SEven :: SParity Even + SOdd :: SParity Odd + +type Defs ( parity :: Parity ) = + '[ "even" ':-> Input '[ Location 0 ] Float + , "odd" ':-> Input '[ Location 1 ] Float + , "main" ':-> EntryPoint '[] Vertex + ] + +shader :: _ => SParity parity -> Module ( Defs parity ) +shader sParity = Module $ entryPoint @"main" @Vertex $ do + val <- readInputFromParity sParity + pure ( Lit () ) + +readInputFromParity :: _ => SParity parity -> Program _s _s ( Code Float ) +readInputFromParity sParity = readInput + where + readInput + :: _ => Program _s _s ( Code Float ) + readInput = case sParity of + SEven -> get @"even" + SOdd -> get @"odd" diff --git a/test/Tests/Interface/ComponentMismatch.golden b/test/Tests/Interface/ComponentMismatch.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Interface/ComponentMismatch.golden @@ -0,0 +1,22 @@ +test/Tests/Interface/ComponentMismatch.hs:56:5: error: [GHC-64725] + • Interface mismatch at location 0. + Output named "out" of Vertex shader named "main" has underlying type V 4 + Float, + whereas input named "in1" of Fragment shader named "main" has underlying type V 3 + Float. + • In the first argument of ‘($)’, namely ‘ShaderPipeline’ + In the expression: + ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex, "vertex.spv") + :>-> (fragment, "fragment.spv") + In an equation for ‘shaderPipeline’: + shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex, "vertex.spv") + :>-> (fragment, "fragment.spv") + | +56 | = ShaderPipeline + | ^^^^^^^^^^^^^^ + diff --git a/test/Tests/Interface/ComponentMismatch.hs b/test/Tests/Interface/ComponentMismatch.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Interface/ComponentMismatch.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Interface.ComponentMismatch where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 4 Float + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in1" ':-> Input '[ Location 0 ] ( V 3 Float ) + , "in2" ':-> Input '[ Location 0, Component 3 ] Float + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + ~(Vec3 x y z) <- get @"in1" + w <- get @"in2" + put @"out" ( Vec4 x y z w ) + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/Interface/ExtraOutput.golden b/test/Tests/Interface/ExtraOutput.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Interface/ExtraOutput.golden @@ -0,0 +1,19 @@ +test/Tests/Interface/ExtraOutput.hs:56:5: error: [GHC-64725] + • Output "out2" of type V 4 Float of Vertex shader named "main", + does not match any input of Fragment shader named "main". + • In the first argument of ‘($)’, namely ‘ShaderPipeline’ + In the expression: + ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex, "vertex.spv") + :>-> (fragment, "fragment.spv") + In an equation for ‘shaderPipeline’: + shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex, "vertex.spv") + :>-> (fragment, "fragment.spv") + | +56 | = ShaderPipeline + | ^^^^^^^^^^^^^^ + diff --git a/test/Tests/Interface/ExtraOutput.hs b/test/Tests/Interface/ExtraOutput.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Interface/ExtraOutput.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Interface.ExtraOutput where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 4 Float + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out1" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "out2" ':-> Output '[ Location 1 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + vec <- get @"in" + put @"out1" vec + put @"out2" vec + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/Interface/InvalidComponent.golden b/test/Tests/Interface/InvalidComponent.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Interface/InvalidComponent.golden @@ -0,0 +1,34 @@ +test/Tests/Interface/InvalidComponent.hs:35:10: error: [GHC-64725] + • Cannot position scalar of type Double + at Location 1, Component 1. + • In the expression: + shader + do put @"out1" =<< get @"in1" + put @"out2" =<< get @"in2" + In an equation for ‘vertex’: + vertex + = shader + do put @"out1" =<< get @"in1" + put @"out2" =<< get @"in2" + | +35 | vertex = shader do + | ^^^^^^ + +test/Tests/Interface/InvalidComponent.hs:50:12: error: [GHC-64725] + • Cannot position scalar of type Double + at Location 1, Component 1. + • In the expression: + shader + do ~(Vec4 x y z _) <- get @"in1" + w <- get @"in2" + put @"out" (Vec4 x y z (convert w)) + In an equation for ‘fragment’: + fragment + = shader + do ~(Vec4 x y z _) <- get @"in1" + w <- get @"in2" + put @"out" (Vec4 x y z (convert w)) + | +50 | fragment = shader do + | ^^^^^^ + diff --git a/test/Tests/Interface/InvalidComponent.hs b/test/Tests/Interface/InvalidComponent.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Interface/InvalidComponent.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Interface.InvalidComponent where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 4 Float + , Slot 1 0 ':-> Double + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in1" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "in2" ':-> Input '[ Location 1 ] Double + , "out1" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "out2" ':-> Output '[ Location 1, Component 1 ] Double + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + put @"out1" =<< get @"in1" + put @"out2" =<< get @"in2" + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in1" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "in2" ':-> Input '[ Location 1, Component 1 ] Double + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + ~(Vec4 x y z _) <- get @"in1" + w <- get @"in2" + put @"out" ( Vec4 x y z ( convert w ) ) + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/Interface/MissingInput.golden b/test/Tests/Interface/MissingInput.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Interface/MissingInput.golden @@ -0,0 +1,19 @@ +test/Tests/Interface/MissingInput.hs:54:5: error: [GHC-64725] + • Input "in2" of type V 4 Float of Fragment shader named "main", + does not match any output of Vertex shader named "main". + • In the first argument of ‘($)’, namely ‘ShaderPipeline’ + In the expression: + ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex, "vertex.spv") + :>-> (fragment, "fragment.spv") + In an equation for ‘shaderPipeline’: + shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex, "vertex.spv") + :>-> (fragment, "fragment.spv") + | +54 | = ShaderPipeline + | ^^^^^^^^^^^^^^ + diff --git a/test/Tests/Interface/MissingInput.hs b/test/Tests/Interface/MissingInput.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Interface/MissingInput.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Interface.MissingInput where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 4 Float + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in1" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "in2" ':-> Input '[ Location 1 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out" =<< get @"in1" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/Layout/Copy.hs b/test/Tests/Layout/Copy.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/Copy.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.Copy where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- copying a structure from a uniform buffer to a storage buffer, +-- which use different layouts + +type S = + Struct + '[ "a" ':-> Array 3 Float + , "b" ':-> V 3 Float + , "c" ':-> Array 2 ( Struct '[ "x" ':-> Float, "y" ':-> V 2 Float ] ) + , "m" ':-> M 4 4 Float + ] + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "s" ':-> S ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "s" ':-> S, "t" ':-> S ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + assign @( Name "out" :.: Name "s" ) =<< use @( Name "ubo" :.: Name "s" ) + assign @( Name "out" :.: Name "t" ) =<< use @( Name "out" :.: Name "s" ) diff --git a/test/Tests/Layout/DescriptorArray.hs b/test/Tests/Layout/DescriptorArray.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/DescriptorArray.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.DescriptorArray where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- arrays of uniform buffers + +type S = Struct '[ "m" ':-> M 4 4 Float, "v" ':-> V 3 Float, "xs" ':-> Array 3 Float ] + +type Defs = + '[ "ubos" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] ( Array 4 S ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "f" ':-> Float, "s" ':-> S ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + i <- use @( Name "gl_LocalInvocationIndex" ) + x <- use @( Name "ubos" :.: AnIndex Word32 :.: Name "xs" :.: Index 1 ) i + s <- use @( Name "ubos" :.: Index 2 ) + whole <- get @"ubos" + assign @( Name "out" :.: Name "f" ) ( x + view @( Index 3 :.: Name "xs" :.: Index 0 ) whole ) + assign @( Name "out" :.: Name "s" ) s diff --git a/test/Tests/Layout/FunctionArgument.hs b/test/Tests/Layout/FunctionArgument.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/FunctionArgument.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.FunctionArgument where + +-- fir +import FIR + +------------------------------------------------ +-- passing a value loaded from a buffer to a function + +type S = Struct '[ "a" ':-> Float, "b" ':-> Array 2 Float ] + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "s" ':-> S ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "res" ':-> Float ] ) + , "f" ':-> Function '[ "s" ':-> Var R S ] Float + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + + ( f :: Code S -> Code Float ) <- fundef @"f" do + s <- get @"s" + pure ( view @( Name "a" ) s + view @( Name "b" :.: Index 1 ) s ) + + entryPoint @"main" @Compute do + s <- use @( Name "ubo" :.: Name "s" ) + assign @( Name "out" :.: Name "res" ) ( f s ) diff --git a/test/Tests/Layout/LocalVariables.hs b/test/Tests/Layout/LocalVariables.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/LocalVariables.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.LocalVariables where + +-- fir +import FIR + +------------------------------------------------ +-- local variables holding values loaded from a buffer + +type S = Struct '[ "i" ':-> Word32, "arr" ':-> Array 4 Float ] + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "s" ':-> S ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "res" ':-> Float, "s" ':-> S ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + s <- use @( Name "ubo" :.: Name "s" ) + let i = view @( Name "i" ) s + -- run-time indexing into a loaded value + assign @( Name "out" :.: Name "res" ) + ( view @( Name "arr" :.: AnIndex ( Code Word32 ) ) i s ) + -- mutable local copy of a loaded value + _ <- def @"t" @RW s + assign @( Name "t" :.: Name "arr" :.: AnIndex Word32 ) i 7 + assign @( Name "out" :.: Name "s" ) =<< get @"t" diff --git a/test/Tests/Layout/Matrices.hs b/test/Tests/Layout/Matrices.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/Matrices.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.Matrices where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- matrices whose columns are smaller than their alignment + +type S = + Struct + '[ "m2" ':-> M 2 2 Float + , "m3" ':-> M 3 3 Float + , "m23" ':-> M 2 3 Float + , "ms" ':-> Array 2 ( M 3 3 Float ) + , "f" ':-> Float + ] + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] ( Struct '[ "s" ':-> S ] ) + , "ssbo" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] ( Struct '[ "s" ':-> S ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + assign @( Name "ssbo" :.: Name "s" ) =<< use @( Name "ubo" :.: Name "s" ) diff --git a/test/Tests/Layout/NestedUniform.hs b/test/Tests/Layout/NestedUniform.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/NestedUniform.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.Nested where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- layout of nested uniform buffer + +type Nested = + Struct + '[ "a" ':-> V 4 Float + , "b" ':-> Word32 + , "c" ':-> Struct + '[ "c1" ':-> V 4 Float + , "c2" ':-> V 4 Double + ] + , "d" ':-> V 2 Int32 + ] + +type Defs = + '[ "uniform" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] Nested + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "vert" ':-> EntryPoint '[ ] Vertex + ] + +program :: Module Defs +program = Module do + entryPoint @"vert" @Vertex do + put @"out" =<< use @( Name "uniform" :.: Name "c" :.: Name "c1" ) diff --git a/test/Tests/Layout/Offsets.hs b/test/Tests/Layout/Offsets.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/Offsets.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.Offsets where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- offsets of structures nested in arrays, and arrays of matrices + +type Defs = + '[ "ssbo" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] + ( Struct + '[ "a" ':-> Float + , "xs" ':-> Array 2 ( Struct '[ "x" ':-> Float ] ) + , "ms" ':-> Array 2 ( M 4 4 Float ) + ] + ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + x <- use @( Name "ssbo" :.: Name "xs" :.: Index 1 :.: Name "x" ) + m <- use @( Name "ssbo" :.: Name "ms" :.: Index 0 ) + assign @( Name "ssbo" :.: Name "a" ) x + assign @( Name "ssbo" :.: Name "ms" :.: Index 1 ) m diff --git a/test/Tests/Layout/PerVertexBlocks.hs b/test/Tests/Layout/PerVertexBlocks.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/PerVertexBlocks.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.PerVertexBlocks where + +-- fir +import FIR + +------------------------------------------------ +-- loading and storing whole per-vertex built-in blocks + +type Defs = + '[ "main" ':-> EntryPoint '[ SpacingEqual, VertexOrderCw, OutputVertices 3 ] TessellationControl ] + +program :: Module Defs +program = Module do + entryPoint @"main" @TessellationControl do + i <- get @"gl_InvocationID" + v <- use @( Name "gl_in" :.: AnIndex Word32 ) i + allIn <- get @"gl_in" + assign @( Name "gl_out" :.: AnIndex Word32 ) i v + assign @( Name "gl_out" :.: AnIndex Word32 :.: Name "gl_PointSize" ) i + ( view @( Index 1 :.: Name "gl_PointSize" ) allIn ) + assign @( Name "gl_TessLevelOuter" :.: Index 0 ) 16 diff --git a/test/Tests/Layout/Products.hs b/test/Tests/Layout/Products.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/Products.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.Products where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- product optics over members of buffers with different layouts + +type AB = Struct '[ "a" ':-> Array 2 Float, "b" ':-> Array 3 ( V 2 Float ) ] + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "a" ':-> Array 2 Float, "b" ':-> Array 3 ( V 2 Float ), "v" ':-> V 4 Float ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "a" ':-> Array 2 Float, "b" ':-> Array 3 ( V 2 Float ), "f" ':-> Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + ab <- use @( Name "ubo" :.: Prod @_ @_ @_ @AB ( Name "a" :*: Name "b" :*: EndProd ) ) + assign @( Name "out" :.: Prod @_ @_ @_ @AB ( Name "a" :*: Name "b" :*: EndProd ) ) ab diff --git a/test/Tests/Layout/PushConstant.hs b/test/Tests/Layout/PushConstant.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/PushConstant.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.PushConstant where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- copying push constants to a storage buffer + +type A = Array 2 ( Struct '[ "a" ':-> Float, "b" ':-> V 3 Float ] ) + +type Defs = + '[ "pc" ':-> PushConstant '[] + ( Struct '[ "m" ':-> M 4 4 Float, "arr" ':-> A ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "arr" ':-> A, "m" ':-> M 4 4 Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + assign @( Name "out" :.: Name "arr" ) =<< use @( Name "pc" :.: Name "arr" ) + assign @( Name "out" :.: Name "m" ) =<< use @( Name "pc" :.: Name "m" ) diff --git a/test/Tests/Layout/RuntimeArray.hs b/test/Tests/Layout/RuntimeArray.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/RuntimeArray.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.RuntimeArray where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- structures containing matrices, in a run-time array + +type E = Struct '[ "p" ':-> V 3 Float, "m" ':-> M 4 3 Float, "a" ':-> Array 2 ( M 2 2 Float ) ] + +type Defs = + '[ "ssbo" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "n" ':-> Word32, "arr" ':-> RuntimeArray E ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + i <- use @( Name "gl_LocalInvocationIndex" ) + e <- use @( Name "ssbo" :.: Name "arr" :.: AnIndex Word32 ) i + let e' = set @( Name "p" ) ( Vec3 1 2 3 ) e + assign @( Name "ssbo" :.: Name "arr" :.: AnIndex Word32 ) ( i + 1 ) ( if i > 3 then e else e' ) diff --git a/test/Tests/Layout/Selection.hs b/test/Tests/Layout/Selection.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/Selection.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.Selection where + +-- vector-sized +import qualified Data.Vector.Sized as Vector + +-- fir +import FIR + +------------------------------------------------ +-- selecting between a value loaded from a buffer +-- and a value constructed in the shader + +type S = Struct '[ "a" ':-> Float, "b" ':-> Array 2 Float ] + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] + ( Struct '[ "s" ':-> S, "x" ':-> Float ] ) + , "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] + ( Struct '[ "s" ':-> S ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + loaded <- use @( Name "ubo" :.: Name "s" ) + x <- use @( Name "ubo" :.: Name "x" ) + let built = Struct ( x :& Lit ( MkArray ( Vector.replicate 3 ) ) :& End ) :: Code S + assign @( Name "out" :.: Name "s" ) ( if x > 0 then loaded else built ) diff --git a/test/Tests/Layout/StructPadding.hs b/test/Tests/Layout/StructPadding.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Layout/StructPadding.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Layout.StructPadding where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- members following a nested structure are placed after its padding + +type T = Struct '[ "v" ':-> V 3 Float ] + +type S = + Struct + '[ "s" ':-> T + , "f" ':-> Float + , "d" ':-> Struct '[ "x" ':-> V 4 Double, "y" ':-> Float ] + , "g" ':-> Float + ] + +type Defs = + '[ "ubo" ':-> Uniform '[ DescriptorSet 0, Binding 0 ] ( Struct '[ "s" ':-> S ] ) + , "ssbo" ':-> StorageBuffer '[ DescriptorSet 0, Binding 1 ] ( Struct '[ "s" ':-> S ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + assign @( Name "ssbo" :.: Name "s" ) =<< use @( Name "ubo" :.: Name "s" ) diff --git a/test/Tests/Matrix/Applicative.hs b/test/Tests/Matrix/Applicative.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Matrix/Applicative.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Matrix.Applicative where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = '[ "mvp1" ':-> Input '[Location 1] (M 3 3 Float) + , "mvp2" ':-> Input '[Location 5] (M 3 3 Float) + , "in_pos" ':-> Input '[Location 0] (V 3 Float) + , "out_pos" ':-> Output '[Location 0] (V 3 Float) + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Vertex do + + mvp1 <- get @"mvp1" + mvp2 <- get @"mvp2" + in_pos <- get @"in_pos" + + let adjustment :: Code Float -> Code Float -> Code Float + adjustment x y = 0.5 * abs (x - y) + adjusted_mvp :: Code (M 3 3 Float) + adjusted_mvp = adjustment <$$> mvp1 <**> mvp2 + + + put @"out_pos" (adjusted_mvp !*^ in_pos) diff --git a/test/Tests/Module/DiffStageDiffName.hs b/test/Tests/Module/DiffStageDiffName.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Module/DiffStageDiffName.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Module.DiffStageDiffName where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- combined vertex and fragment shaders + +type Defs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "vert" ':-> EntryPoint '[ ] Vertex + , "frag" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +program :: Module Defs +program = Module do + entryPoint @"vert" @Vertex do + put @"out" =<< get @"in" + entryPoint @"frag" @Fragment do + put @"out" =<< get @"in" diff --git a/test/Tests/Module/DiffStageSameName.hs b/test/Tests/Module/DiffStageSameName.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Module/DiffStageSameName.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Module.DiffStageSameName where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- combined vertex and fragment shaders + +type Defs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Vertex do + put @"out" =<< get @"in" + entryPoint @"main" @Fragment do + put @"out" =<< get @"in" diff --git a/test/Tests/Module/SameStageDiffName.hs b/test/Tests/Module/SameStageDiffName.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Module/SameStageDiffName.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Module.SameStageDiffName where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- combined vertex shaders (with different names) + +type Defs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "vert1" ':-> EntryPoint '[ ] Vertex + , "vert2" ':-> EntryPoint '[ ] Vertex + ] + +program :: Module Defs +program = Module do + entryPoint @"vert1" @Vertex do + put @"out" =<< get @"in" + entryPoint @"vert2" @Vertex do + put @"out" =<< get @"in" diff --git a/test/Tests/Module/SameStageSameName.golden b/test/Tests/Module/SameStageSameName.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Module/SameStageSameName.golden @@ -0,0 +1,16 @@ +test/Tests/Module/SameStageSameName.hs:27:3: error: [GHC-64725] + • 'entryPoint': duplicate entry point declaration. + There already exists a Vertex shader named "main". + • In a stmt of a 'do' block: + entryPoint @"main" @Vertex do put @"out" =<< get @"in" + In the first argument of ‘Module’, namely + ‘do entryPoint @"main" @Vertex do put @"out" =<< get @"in" + entryPoint @"main" @Vertex do put @"out" =<< get @"in"’ + In the expression: + Module + do entryPoint @"main" @Vertex do put @"out" =<< get @"in" + entryPoint @"main" @Vertex do put @"out" =<< get @"in" + | +27 | entryPoint @"main" @Vertex do + | ^^^^^^^^^^ + diff --git a/test/Tests/Module/SameStageSameName.hs b/test/Tests/Module/SameStageSameName.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Module/SameStageSameName.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Module.SameStageSameName where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- duplicate entrypoints (not allowed) + +type Defs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + , "main" ':-> EntryPoint '[ ] Vertex + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Vertex do + put @"out" =<< get @"in" + entryPoint @"main" @Vertex do + put @"out" =<< get @"in" diff --git a/test/Tests/OpenCL/Kernel.hs b/test/Tests/OpenCL/Kernel.hs new file mode 100644 --- /dev/null +++ b/test/Tests/OpenCL/Kernel.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.OpenCL.Kernel where + +-- base +import GHC.TypeNats + ( Nat, type (*), type (-) ) + +-- fir +import FIR + +------------------------------------------------ +-- program + +type N = ( 128 :: Nat ) +n :: Code Int32 +n = Lit $ fromIntegral ( knownValue @N ) + +type Defs = '[ "arr" ':-> CrossWorkgroup '[] ( Array (N * N) Float ) + , "main" ':-> EntryPoint '[ LocalSize (2 * N - 1) 1 1 ] Kernel + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Kernel do + + -- 0 ≤ diag < 2 * n - 1 + ( diag :: Code Int32 ) + <- convert <<$>> get @"cl_GlobalLinearID" + + _ <- def @"entry" @RW @Int32 0 + let + diagSize :: Code Int32 + diagSize = n - abs ( n - diag - 1 ) + while ( get @"entry" < pure diagSize ) do + entry <- get @"entry" + + let + row, col :: Code Int32 + row = min ( n - 1 ) diag - entry + col = max 0 ( diag - n + 1 ) + entry + + _ <- def @"left" @RW @Float 1 + when ( col > 0 ) do + put @"left" =<< ( use @(Name "arr" :.: AnIndex Int32) ( n * row + ( col - 1 ) ) ) + + _ <- def @"up" @RW @Float 1 + when ( row > 0 ) do + put @"up" =<< ( use @(Name "arr" :.: AnIndex Int32) ( n * ( row - 1 ) + col ) ) + + left <- get @"left" + up <- get @"up" + assign @(Name "arr" :.: AnIndex Int32) ( n * row + col ) ( left + up ) + + modify @"entry" (+1) + + pure (Lit ()) diff --git a/test/Tests/Optics/ASTIndices.hs b/test/Tests/Optics/ASTIndices.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/ASTIndices.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.ASTIndices where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = + '[ "nested" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] + ( Array 4 ( Struct '[ "r" ':-> Float, "ijk" ':-> V 3 Float ] ) ) + , "out1" ':-> Output '[Location 0] ( V 4 Float ) + , "out2" ':-> Output '[Location 1] ( M 3 2 Float ) + , "main" ':-> EntryPoint '[] Vertex + ] + +type TwoFloats + = Struct + '[ "1" ':-> Float + , "2" ':-> Float + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Vertex do + + r <- use @(Name "nested" :.: AnIndex Word32 :.: Name "r") 3 + + twoFloats + <- use @( Name "nested" + :.: Prod @_ @_ @_ @TwoFloats + ( ( AnIndex Word32 :.: Name "ijk" :.: AnIndex Word32 ) + :*: ( AnIndex Word32 :.: Name "ijk" :.: AnIndex Word32 ) + :*: EndProd + ) + ) + ( ConsHList :$ 1 :$ ( ConsHList :$ 2 :$ NilHList ) ) + ( ConsHList :$ 4 :$ ( ConsHList :$ 3 :$ NilHList ) ) + let f = view @(Index 1) twoFloats + + assign @(Name "out1" :.: AnIndex Word32) 0 (r + f) + + let + mat :: Code (M 3 4 Float) + mat = Mat34 + 0 1 2 3 + 4 5 6 7 + 8 9 10 11 + + mat' :: Code (M 3 2 Float) + mat' = view @( Prod ( Col 1 :*: Col 3 :*: EndProd ) ) mat + + assign @(Name "out2") mat' + + assign @(Name "out2" :.: Rows) (Vec2 1 3) diff --git a/test/Tests/Optics/ASTProducts.hs b/test/Tests/Optics/ASTProducts.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/ASTProducts.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.ASTProducts where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = + '[ "ubo" ':-> Uniform '[Binding 0, DescriptorSet 0] ( Struct '[ "mvp" ':-> M 4 4 Float ] ) + , "out" ':-> Output '[Location 0] ( M 4 4 Float ) + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Vertex do + + row <- use @(Name "ubo" :.: Name "mvp" :.: Row 0) + col <- use @(Name "ubo" :.: Name "mvp" :.: Col 2) + dia <- use @(Name "ubo" :.: Name "mvp" :.: Diag) + ( mid :: Code (M 2 2 Float) ) + <- use @(Name "ubo" :.: Name "mvp" :.: Prod (Entry 1 1 :*: Entry 1 2 :*: Entry 2 1 :*: Entry 2 2 :*: EndProd)) + ( flatMid :: Code (V 4 Float) ) + <- use @(Name "ubo" :.: Name "mvp" :.: Prod (Entry 1 1 :*: Entry 1 2 :*: Entry 2 1 :*: Entry 2 2 :*: EndProd)) + + assign @(Name "out") identity + assign @(Name "out" :.: Diag) dia + assign @(Name "out" :.: Prod (Entry 1 1 :*: Entry 1 2 :*: Entry 2 1 :*: Entry 2 2 :*: EndProd)) mid + assign @(Name "out" :.: Col 3) col + assign @(Name "out" :.: Row 2) row + assign @(Name "out" :.: Row 1) flatMid diff --git a/test/Tests/Optics/MVP1.hs b/test/Tests/Optics/MVP1.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/MVP1.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.MVP1 where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = '[ "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] + ( Struct '[ "mvp" ':-> M 4 4 Float ] ) + , "in_pos" ':-> Input '[ Location 0 ] (V 4 Float) + , "out_pos" ':-> Output '[ Location 0 ] (V 4 Float) + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = + Module $ entryPoint @"main" @Vertex do + mvp <- use @(Name "ubo" :.: Name "mvp") + in_pos <- get @"in_pos" + put @"out_pos" (mvp !*^ in_pos) diff --git a/test/Tests/Optics/MVP2.hs b/test/Tests/Optics/MVP2.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/MVP2.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.MVP2 where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = '[ "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] + ( Struct '[ "mvp" ':-> M 4 4 Float ] ) + , "in_pos" ':-> Input '[ Location 0 ] (V 4 Float) + , "out_pos" ':-> Output '[ Location 0 ] (V 4 Float) + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = + Module $ entryPoint @"main" @Vertex do + ubo <- use @(Name "ubo") + let mvp = view @(Name "mvp") ubo + in_pos <- get @"in_pos" + let out_pos = set @(Index 3) 1 $ mvp !*^ in_pos + put @"out_pos" out_pos diff --git a/test/Tests/Optics/NestedOfType.hs b/test/Tests/Optics/NestedOfType.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/NestedOfType.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.NestedOfType where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- setting all components of a given type, nested inside arrays and structures + +type S = + Struct + '[ "a" ':-> Array 2 Float + , "b" ':-> Array 3 ( V 2 Float ) + , "c" ':-> Struct '[ "x" ':-> Word32, "y" ':-> Array 2 ( Struct '[ "z" ':-> Float ] ) ] + , "m" ':-> M 2 2 Float + ] + +type Defs = + '[ "out" ':-> StorageBuffer '[ DescriptorSet 0, Binding 0 ] ( Struct '[ "s" ':-> S, "v" ':-> V 2 Float ] ) + , "main" ':-> EntryPoint '[ LocalSize 1 1 1 ] Compute + ] + +program :: Module Defs +program = Module do + entryPoint @"main" @Compute do + assign @( Name "out" :.: OfType Float ) 5 + assign @( Name "out" :.: Name "s" :.: Name "b" :.: OfType Float ) 3 + assign @( Name "out" :.: OfType ( V 2 Float ) :.: Index 1 ) ( 7 :: Code Float ) diff --git a/test/Tests/Optics/NoMatrixIndex.golden b/test/Tests/Optics/NoMatrixIndex.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/NoMatrixIndex.golden @@ -0,0 +1,18 @@ +test/Tests/Optics/NoMatrixIndex.hs:31:10: error: [GHC-64725] + • Matrix column index 4 is out of bounds. + This matrix has 3 rows, 4 columns. + Note: indexing starts from 0. + • In a stmt of a 'do' block: + c <- use @(Name "vertexData" :.: Entry 1 4) + In the third argument of ‘entryPoint’, namely + ‘do c <- use @(Name "vertexData" :.: Entry 1 4) + put @"gl_Position" (Vec4 c c c 1)’ + In a stmt of a 'do' block: + entryPoint + @"main" @Vertex + do c <- use @(Name "vertexData" :.: Entry 1 4) + put @"gl_Position" (Vec4 c c c 1) + | +31 | c <- use @( Name "vertexData" :.: Entry 1 4 ) + | ^^^ + diff --git a/test/Tests/Optics/NoMatrixIndex.hs b/test/Tests/Optics/NoMatrixIndex.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/NoMatrixIndex.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.NoMatrixIndex where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "vertexData" ':-> Input '[ Location 0 ] ( M 3 4 Float ) + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Vertex do + + c <- use @( Name "vertexData" :.: Entry 1 4 ) + + put @"gl_Position" (Vec4 c c c 1) diff --git a/test/Tests/Optics/NoStructField.golden b/test/Tests/Optics/NoStructField.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/NoStructField.golden @@ -0,0 +1,19 @@ +test/Tests/Optics/NoStructField.hs:37:17: error: [GHC-64725] + • Structure has no field with name "inexistent". + This structure has the following fields: + ["position" ':-> V 3 Float, "colour" ':-> V 4 Float, + "size" ':-> Float, "weight" ':-> Float] + • In a stmt of a 'do' block: + position <- use @(Name "vertexData" :.: Name "inexistent") + In the third argument of ‘entryPoint’, namely + ‘do position <- use @(Name "vertexData" :.: Name "inexistent") + put @"gl_Position" position’ + In a stmt of a 'do' block: + entryPoint + @"main" @Vertex + do position <- use @(Name "vertexData" :.: Name "inexistent") + put @"gl_Position" position + | +37 | position <- use @( Name "vertexData" :.: Name "inexistent" ) + | ^^^ + diff --git a/test/Tests/Optics/NoStructField.hs b/test/Tests/Optics/NoStructField.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/NoStructField.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.NoStructField where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "vertexData" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] + ( Struct [ "position" ':-> V 3 Float + , "colour" ':-> V 4 Float + , "size" ':-> Float + , "weight" ':-> Float + ] + ) + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Vertex do + + position <- use @( Name "vertexData" :.: Name "inexistent" ) + + put @"gl_Position" position diff --git a/test/Tests/Optics/NoStructIndex.golden b/test/Tests/Optics/NoStructIndex.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/NoStructIndex.golden @@ -0,0 +1,20 @@ +test/Tests/Optics/NoStructIndex.hs:42:17: error: [GHC-64725] + • Index 5 out of bounds when accessing structure with fields + ["position" ':-> V 3 Float, "colour" ':-> V 4 Float, + "size" ':-> Float, "weight" ':-> Float] + Structure has only 4 fields. + Note: indexing starts from 0. + • In a stmt of a 'do' block: + position <- use @(Name "vertexData" :.: Index 5) + In the third argument of ‘entryPoint’, namely + ‘do position <- use @(Name "vertexData" :.: Index 5) + #gl_Position .= position’ + In a stmt of a 'do' block: + entryPoint + @"main" @Vertex + do position <- use @(Name "vertexData" :.: Index 5) + #gl_Position .= position + | +42 | position <- use @( Name "vertexData" :.: Index 5 ) + | ^^^ + diff --git a/test/Tests/Optics/NoStructIndex.hs b/test/Tests/Optics/NoStructIndex.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/NoStructIndex.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.NoStructIndex where + +-- vector +import qualified Data.Vector as Array + +-- fir +import FIR +import FIR.Syntax.Labels +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "vertexData"':-> Uniform '[ Binding 0, DescriptorSet 0 ] + ( Struct [ "position" ':-> V 3 Float + , "colour" ':-> V 4 Float + , "size" ':-> Float + , "weight" ':-> Float + ] + ) + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Vertex do + + position <- use @( Name "vertexData" :.: Index 5 ) + + #gl_Position .= position diff --git a/test/Tests/Optics/NoVectorIndex.golden b/test/Tests/Optics/NoVectorIndex.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/NoVectorIndex.golden @@ -0,0 +1,18 @@ +test/Tests/Optics/NoVectorIndex.hs:36:17: error: [GHC-64725] + • Vector index 4 is out of bounds. + Vector dimension is 4. + Note: indexing starts from 0. + • In a stmt of a 'do' block: + position <- use @(Name "vertexData" :.: Index 4) + In the third argument of ‘entryPoint’, namely + ‘do position <- use @(Name "vertexData" :.: Index 4) + #gl_Position .= position’ + In a stmt of a 'do' block: + entryPoint + @"main" @Vertex + do position <- use @(Name "vertexData" :.: Index 4) + #gl_Position .= position + | +36 | position <- use @( Name "vertexData" :.: Index 4 ) + | ^^^ + diff --git a/test/Tests/Optics/NoVectorIndex.hs b/test/Tests/Optics/NoVectorIndex.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/NoVectorIndex.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.NoVectorIndex where + +-- vector +import qualified Data.Vector as Array + +-- fir +import FIR +import FIR.Syntax.Labels +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "vertexData" ':-> Input '[Location 0] ( V 4 Float ) + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Vertex do + + position <- use @( Name "vertexData" :.: Index 4 ) + + #gl_Position .= position diff --git a/test/Tests/Optics/Overlapping.golden b/test/Tests/Optics/Overlapping.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/Overlapping.golden @@ -0,0 +1,36 @@ +test/Tests/Optics/Overlapping.hs:33:5: error: [GHC-64725] + • Cannot create product setter at type: + Struct ["field_0" ':-> Float, "field_1" ':-> Bool] + Overlap between optics + - Name "field_0", + - Index 0, + at index 0. + • In a stmt of a 'do' block: + assign + @(Name "struct" + :.: + (Prod (Name "field_0" + :*: Index 0 :*: EndProd) :: Optic '[] MyStruct OtherStruct)) + (Lit (4 :& 5 :& End)) + In the third argument of ‘entryPoint’, namely + ‘do def @"struct" @RW @MyStruct (Lit (3 :& True :& End)) + assign + @(Name "struct" + :.: + (Prod (Name "field_0" + :*: Index 0 :*: EndProd) :: Optic '[] MyStruct OtherStruct)) + (Lit (4 :& 5 :& End))’ + In a stmt of a 'do' block: + entryPoint + @"main" @Vertex + do def @"struct" @RW @MyStruct (Lit (3 :& True :& End)) + assign + @(Name "struct" + :.: + (Prod (Name "field_0" + :*: Index 0 :*: EndProd) :: Optic '[] MyStruct OtherStruct)) + (Lit (4 :& 5 :& End)) + | +33 | assign + | ^^^^^^ + diff --git a/test/Tests/Optics/Overlapping.hs b/test/Tests/Optics/Overlapping.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/Overlapping.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.Overlapping where + +-- fir +import FIR +import FIR.Syntax.Labels +import Math.Linear + +------------------------------------------------ +-- program + +type MyStruct = Struct '[ "field_0" ':-> Float, "field_1" ':-> Bool ] +type OtherStruct = Struct '[ "x" ':-> Float, "y" ':-> Float ] + +program :: Module '[ "main" ':-> EntryPoint '[] Vertex ] +program = Module do + + entryPoint @"main" @Vertex do + + def @"struct" @RW @MyStruct + ( Lit ( 3 :& True :& End ) ) + + assign + @( Name "struct" + :.: ( Prod (Name "field_0" :*: Index 0 :*: EndProd) + :: Optic '[] + MyStruct + OtherStruct + ) + ) + ( Lit ( 4 :& 5 :& End ) ) diff --git a/test/Tests/Optics/ProductIndices.golden b/test/Tests/Optics/ProductIndices.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/ProductIndices.golden @@ -0,0 +1,1 @@ +No type-checking errors. diff --git a/test/Tests/Optics/ProductIndices.hs b/test/Tests/Optics/ProductIndices.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/ProductIndices.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.ProductIndices where + +-- prelude +import qualified Prelude + ( Functor(fmap) ) +import Data.Maybe + ( fromJust ) + +-- vector-sized +import qualified Data.Vector.Sized as Vector + +-- fir +import FIR +import Math.Linear + +-- fir +import FIR + +------------------------------------------------ +-- testing product runtime indices + +arr1 :: Array 12 Float +arr1 = MkArray ( fromJust $ Vector.fromList [10..21] ) + +test1 :: (Float, Float, Float) +test1 = view @( Prod (AnIndex Word32 :*: AnIndex Word32 :*: AnIndex Word32 :*: EndProd) ) + ( 2 :> 7 :> 3 :> HNil ) + arr1 + +-- > test1 +-- (12.0,17.0,13.0) + +test2 :: HList '[ Float, Float, Float ] +test2 = view @( Prod (AnIndex Word32 :*: AnIndex Word32 :*: AnIndex Word32 :*: EndProd) ) + ( 2 :> 7 :> 3 :> HNil ) + arr1 + +-- > test2 +-- 12.0 :> 17.0 :> 13.0 :> HNil + + +arr2 :: Array 2 ( Array 12 Float ) +arr2 = MkArray ( fromJust $ Vector.fromList [ Prelude.fmap (+10) arr1, arr1 ] ) + +test3 :: ( Float, Float ) +test3 = view @( AnIndex Word32 :.: ( Prod (AnIndex Word32 :*: AnIndex Word32 :*: EndProd) ) ) + 0 + ( 11 :> 0 :> HNil ) + arr2 + +-- > test3 +-- (31.0,20.0) + +-- doesn't work +--test4 :: ( Float, Float ) +--test4 = view @( ( Prod (AnIndex Word32 :*: AnIndex Word32 :*: EndProd) ) :.: AnIndex Word32 ) +-- ( 1 :> 0 :> HNil ) +-- 7 +-- arr2 diff --git a/test/Tests/Optics/PureProducts.golden b/test/Tests/Optics/PureProducts.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/PureProducts.golden @@ -0,0 +1,1 @@ +No type-checking errors. diff --git a/test/Tests/Optics/PureProducts.hs b/test/Tests/Optics/PureProducts.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/PureProducts.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.PureProducts where + +-- base +import qualified Prelude + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- testing product getters + +-- structs + +struct1 :: Struct '[ "x" ':-> Float, "y" ':-> Float, "z" ':-> Float ] +struct1 = 11.1 :& 7 :& 3.0 :& End + +struct2 :: Struct '[ "x" ':-> Float, "z" ':-> Float ] +struct2 = view @(Prod (Name "x" :*: Name "z" :*: EndProd)) struct1 + +struct3 :: Struct '[ "x" ':-> Float, "z" ':-> Float, "x" ':-> Float ] +struct3 = view @(Prod (Name "x" :*: Name "z" :*: Name "x" :*: EndProd)) struct1 + +nested1 + :: Struct + '[ "a" ':-> Float + , "b" ':-> Struct + '[ "r" ':-> V 3 Float + , "s" ':-> M 4 4 Double + , "t" ':-> Struct + '[ "u" ':-> Double + , "v" ':-> Double + ] + ] + ] +nested1 = 17.3 :& ( Prelude.pure 7.77 :& diag 4.1 :& ( 3 :& 4 :& End ) :& End ) :& End + +nested2 :: Struct '[ "a" ':-> Float, "r" ':-> V 3 Float ] +nested2 = view @(Prod ( Name "a" :*: (Name "b" :.: Index 0) :*: EndProd)) nested1 + +nested3 :: Struct '[ "r" ':-> V 3 Float + , "s" ':-> M 4 4 Double + ] +nested3 = view @(Name "b" :.: (Prod (Name "r" :*: Name "s" :*: EndProd))) nested1 + + +type RS + = Struct + '[ "r" ':-> V 3 Float + , "s" ':-> M 4 4 Double + ] + +nested4 :: Struct '[ "a" ':-> Float + , "b" ':-> Struct '[ "r" ':-> V 3 Float + , "s" ':-> M 4 4 Double + ] + ] +nested4 = view @( Prod + ( Index 0 + :*: ( Name "b" :.: (Prod @_ @_ @_ @RS (Name "r" :*: Name "s" :*: EndProd)) ) + :*: EndProd + ) + ) + nested1 + + +-- vectors + +v1 :: V 3 Double +v1 = 0 :. 11 :. 77 :. VNil + +v2 :: V 2 Double +v2 = view @(Prod (Index 2 :*: Index 0 :*: EndProd)) v1 + +-- matrices + +m1 :: M 4 4 Float +m1 = identity + +m2 :: M 4 2 Float +m2 = view @(Prod (Col 2 :*: Col 1 :*: EndProd)) m1 + +m3 :: M 4 2 Float +m3 = view @(Prod (Col 2 :*: Col 3 :*: EndProd)) m1 + +m4 :: M 2 2 Float +m4 = view @(Prod (Entry 1 1 :*: Entry 1 2 :*: Entry 2 1 :*: Entry 2 2 :*: EndProd)) m1 + +m5 :: V 3 Float +m5 = view @(Prod (Entry 1 1 :*: Entry 3 3 :*: Entry 2 0 :*: EndProd)) m1 + +------------------------------------------------ +-- testing product setters + +struct4 :: Struct '[ "x" ':-> Float, "y" ':-> Float, "z" ':-> Float ] +struct4 = + let part :: Struct '[ "y" ':-> Float, "z" ':-> Float ] + part = 8.8 :& 11.0 :& End + in set @( Prod ( (Name "y" :*: Name "z" :*: EndProd) ) ) + part + struct1 + +struct5 :: Struct '[ "x" ':-> Float, "y" ':-> Float, "z" ':-> Float ] +struct5 = + let part :: Struct '[ "field1" ':-> Float, "field2" ':-> Float ] + part = 8.8 :& 11.0 :& End + in set @( Prod ( (Name "y" :*: Name "x" :*: EndProd) ) ) + part + struct1 + +nested5 + :: Struct + '[ "a" ':-> Float + , "b" ':-> Struct + '[ "r" ':-> V 3 Float + , "s" ':-> M 4 4 Double + , "t" ':-> Struct + '[ "u" ':-> Double + , "v" ':-> Double + ] + ] + ] +nested5 = + let part :: Struct '[ "a" ':-> Float, "s" ':-> M 4 4 Double ] + part = 0 :& identity :& End + in set @( Prod ( Index 0 :*: (Name "b" :.: Name "s") :*: EndProd )) + part + nested1 + +m6 :: M 3 3 Float +m6 = M ( V3 + (V3 0 1 2) + (V3 3 4 5) + (V3 6 7 8) + ) + +m7 :: M 3 3 Float +m7 = set @( Prod @_ @_ @_ @(V 3 Float) ( Entry 0 0 :*: Entry 0 2 :*: Entry 2 2 :*: EndProd ) :.: OfType Float ) 9 m6 + +m8 :: M 3 3 Float +m8 = set @Center 9 m6 + +m9 :: M 3 3 Float +m9 = set @( Prod ( Entry 0 0 :*: Entry 2 0 :*: Entry 0 2 :*: Entry 2 2 :*: EndProd ) ) m4 m6 diff --git a/test/Tests/Optics/UnarySwizzle.hs b/test/Tests/Optics/UnarySwizzle.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/UnarySwizzle.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds, PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PartialTypeSignatures #-} + +module UnarySwizzle where + +import FIR +import Math.Linear + +type ComputeDefs = + '[ "positions" ':-> StorageBuffer [DescriptorSet 1, Binding 0 ] + (Struct '["posArray" ':-> RuntimeArray (Struct '[ "pos" ':-> V 2 Float ])]) + , "main" ':-> EntryPoint '[LocalSize 256 1 1] Compute + ] + +program :: Module ComputeDefs +program = Module $ entryPoint @"main" @Compute do + positions <- use @(Name "positions" :.: Name "posArray" :.: AnIndex Word32) 0 + pos' <- let' $ over @(Name "pos" :.: O) (+ 0.01) positions + assign @(Name "positions" :.: Name "posArray" :.: AnIndex Word32) 0 positions + +type O = + ( Prod ( ( Index 0 :: Optic '[] (Code (V 2 Float)) (Code Float) ) :*: EndProd ) + :: Optic '[] (Code (V 2 Float)) (Code Float) ) diff --git a/test/Tests/Optics/Various.hs b/test/Tests/Optics/Various.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Optics/Various.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Optics.Various where + +-- base +import Data.Maybe + ( fromJust ) + +-- vector-sized +import qualified Data.Vector.Sized as Vector + +-- fir +import FIR +import FIR.Syntax.Labels +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] + ( Struct + [ "modelMatrix" ':-> M 4 4 Float + , "viewMatrix" ':-> M 4 4 Float + , "projectionMatrix" ':-> M 4 4 Float + ] + ) + , "vertexData" ':-> + Uniform '[ Binding 1, DescriptorSet 0 ] + ( Struct + [ "position" ':-> V 3 Float + , "colour" ':-> V 4 Float + , "size" ':-> Float + , "weight" ':-> Float + ] + ) + , "arr1" ':-> + Uniform '[ Binding 2, DescriptorSet 0 ] + ( Array 12 + ( Struct + [ "label1" ':-> V 3 Float + , "label2" ':-> Array 3 Float + ] + ) + ) + , "arr2" ':-> + StorageBuffer '[ Binding 3, DescriptorSet 0 ] + ( Struct + [ "x1" ':-> V 4 Float + , "x2" ':-> Float + , "rt" ':-> RuntimeArray Float + ] + ) + , "main" ':-> EntryPoint '[] Vertex + , "out_col" ':-> Output '[Location 0] ( V 4 Float ) + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Vertex do + + modelMatrix <- use @(Name "ubo" :.: Name "modelMatrix" ) + viewMatrix <- use @(Name "ubo" :.: Name "viewMatrix" ) + projectionMatrix <- use @(Name "ubo" :.: Name "projectionMatrix" ) + let mvp = modelMatrix !*! viewMatrix !*! projectionMatrix + + vertexData <- use @( Name "vertexData" ) + let vertexDataColour = view @(Name "colour") vertexData + row <- use @( Name "ubo" :.: Name "modelMatrix" :.: Row 2 ) + diagonal <- use @(Name "ubo" :.: Name "modelMatrix" :.: Diag ) + lensTest <- use @(Name "arr1" :.: AnIndex Word32 :.: Index 0 :.: Index 2) 7 + rtTest1 <- use @(Name "arr2" :.: Name "rt" :.: AnIndex Word32) 6 + rtTest2 <- use @(Name "arr2" :.: Name "rt" :.: Index 6) + + #array @(Array 10 Float) #= (Lit $ MkArray (fromJust $ Vector.fromList [1,17,23,4,5,90,88,17,22,21])) + #gl_Position .= (rtTest1 * rtTest2 + abs lensTest) *^ ( mvp !*^ diagonal ) + #out_col .= vertexDataColour ^+^ row diff --git a/test/Tests/PrimOps/Rounding.hs b/test/Tests/PrimOps/Rounding.hs new file mode 100644 --- /dev/null +++ b/test/Tests/PrimOps/Rounding.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.PrimOps.Rounding where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = '[ "x" ':-> Input '[Location 0] Float + , "y" ':-> Input '[Location 1] Int32 + , "z" ':-> Input '[Location 2] Float + , "out" ':-> Output '[Location 0] (V 4 Float) + , "main" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Vertex do + + x <- get @"x" + let x' = x - floor x + z <- get @"z" + z1 :: Code Int32 <- round ( get @"z" ) + let z2 :: Code Int32 + z2 = truncate z + y' <- convert $ get @"y" + pure z1 - pure z2 + let w = ceiling x + z + + put @"out" (Vec4 x' y' z w) diff --git a/test/Tests/ProgramState/Shadowing.hs b/test/Tests/ProgramState/Shadowing.hs new file mode 100644 --- /dev/null +++ b/test/Tests/ProgramState/Shadowing.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.ProgramState.Shadowing where + +-- fir +import FIR + +------------------------------------------------ +-- program + +type Defs = '[ "out" ':-> Output '[Location 0] Float + , "main" ':-> EntryPoint '[OriginUpperLeft] Fragment + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @Fragment do + + t <- def @"t" @R @Float 5.5 + + inner + + s <- def @"s" @R @Float 7.7 + t' <- get @"t" + + put @"out" (t + s + t') + + +inner :: Program i i (Code Word32) +inner = purely do + def @"t" @R @Word32 3 + def @"s" @R @Word32 4 diff --git a/test/Tests/Small/HalfArithmetic.hs b/test/Tests/Small/HalfArithmetic.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Small/HalfArithmetic.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Small.HalfArithmetic where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "in_col" ':-> Input '[ Location 0 ] (V 4 Float) + , "out_col" ':-> Output '[ Location 0 ] (V 4 Float) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +program :: Module Defs +program = + Module $ entryPoint @"main" @Fragment do + def @"h" @R @Half (5 * pi / 4) + h <- get @"h" + if abs (cos h) > sqrt 2 + then put @"out_col" =<< get @"in_col" + else put @"out_col" (Vec4 0 0 0 1) diff --git a/test/Tests/Small/HalfInputOutput.hs b/test/Tests/Small/HalfInputOutput.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Small/HalfInputOutput.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Small.HalfInputOutput where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "in_col" ':-> Input '[ Location 0 ] (V 4 Half) + , "out_col" ':-> Output '[ Location 0 ] (V 4 Half) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +program :: Module Defs +program = + Module $ entryPoint @"main" @Vertex do + put @"out_col" =<< get @"in_col" diff --git a/test/Tests/Small/IntArithmetic.hs b/test/Tests/Small/IntArithmetic.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Small/IntArithmetic.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Small.IntArithmetic where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "in_col" ':-> Input '[ Location 0 ] (V 4 Float) + , "out_col" ':-> Output '[ Location 0 ] (V 4 Float) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +program :: Module Defs +program = + Module $ entryPoint @"main" @Fragment do + _ <- def @"i" @R @Int16 ( - 5 * 4 ) + _ <- def @"j" @R @Word8 ( 7 + 11 ) + i <- get @"i" + j <- get @"j" + if 3 * abs i + convert j > 0 + then put @"out_col" =<< get @"in_col" + else put @"out_col" (Vec4 0 0 0 1) diff --git a/test/Tests/Small/IntInputOutput.hs b/test/Tests/Small/IntInputOutput.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Small/IntInputOutput.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Small.IntInputOutput where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "in_a" ':-> Input '[ Location 0 ] (V 4 Int8 ) + , "in_b" ':-> Input '[ Location 1 ] (V 4 Word8 ) + , "in_c" ':-> Input '[ Location 2 ] (V 4 Int16 ) + , "in_d" ':-> Input '[ Location 3 ] (V 4 Word16) + , "out_a" ':-> Output '[ Location 0 ] (V 4 Int8 ) + , "out_b" ':-> Output '[ Location 1 ] (V 4 Word8 ) + , "out_c" ':-> Output '[ Location 2 ] (V 4 Int16 ) + , "out_d" ':-> Output '[ Location 3 ] (V 4 Word16) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +program :: Module Defs +program = + Module $ entryPoint @"main" @Vertex do + put @"out_a" =<< get @"in_a" + put @"out_b" =<< get @"in_b" + put @"out_c" =<< get @"in_c" + put @"out_d" =<< get @"in_d" diff --git a/test/Tests/Tessellation/Control.hs b/test/Tests/Tessellation/Control.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Tessellation/Control.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Tessellation.Control where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = + '[ "in_col" ':-> Input '[ Location 0 ] (Array 3 (V 4 Float)) + , "out_col" ':-> Output '[ Location 0 ] (Array 3 (V 4 Float)) + , "patchOut" ':-> Output '[ Location 1, Patch ] + ( Struct '[ "center" ':-> V 4 Float ] ) + , "main" ':-> EntryPoint '[ SpacingEqual, VertexOrderCw, OutputVertices 3 ] + TessellationControl + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @TessellationControl do + + i <- get @"gl_InvocationID" + in_pos <- use @(Name "gl_in" :.: AnIndex Word32 :.: Name "gl_Position") i + in_col <- use @(Name "in_col" :.: AnIndex Word32) i + center <- + ( recip 3 *^ ) $ use @(Name "gl_in" :.: Index 0 :.: Name "gl_Position") + ^+^ use @(Name "gl_in" :.: Index 1 :.: Name "gl_Position") + ^+^ use @(Name "gl_in" :.: Index 2 :.: Name "gl_Position") + + assign @(Name "gl_TessLevelInner" :.: Index 0) 16 + assign @(Name "gl_TessLevelInner" :.: Index 1) 16 + assign @(Name "gl_TessLevelOuter" :.: Index 0) 16 + assign @(Name "gl_TessLevelOuter" :.: Index 1) 16 + assign @(Name "gl_TessLevelOuter" :.: Index 2) 16 + assign @(Name "gl_TessLevelOuter" :.: Index 3) 16 + + assign @(Name "gl_out" :.: AnIndex Word32 :.: Name "gl_Position") i in_pos + assign @(Name "out_col" :.: AnIndex Word32) i in_col + assign @(Name "patchOut" :.: Name "center") center diff --git a/test/Tests/Tessellation/Evaluation.hs b/test/Tests/Tessellation/Evaluation.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Tessellation/Evaluation.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Tessellation.Evaluation where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = + '[ "in_cols" ':-> Input '[ Location 0 ] (Array 3 (V 4 Float)) + , "out_col" ':-> Output '[ Location 0 ] (V 4 Float) + , "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] + ( Struct '[ "mvp" ':-> M 4 4 Float + , "origin" ':-> V 4 Float + ] + ) + , "main" ':-> EntryPoint '[ Triangles ] TessellationEvaluation + ] + +program :: Module Defs +program = Module $ entryPoint @"main" @TessellationEvaluation do + ~(Vec3 u v w) <- get @"gl_TessCoord" + + in_cols <- get @"in_cols" + put @"out_col" ( u *^ (view @(Index 0) in_cols) + ^+^ v *^ (view @(Index 1) in_cols) + ^+^ w *^ (view @(Index 2) in_cols) + ) + + pos0 <- use @(Name "gl_in" :.: Index 0 :.: Name "gl_Position") + pos1 <- use @(Name "gl_in" :.: Index 1 :.: Name "gl_Position") + pos2 <- use @(Name "gl_in" :.: Index 2 :.: Name "gl_Position") + orig <- use @(Name "ubo" :.: Name "origin") + let t = 0.5 - (2*u - 1)**2 * (2*v - 1)**2 * (2*w - 1)**2 + put @"gl_Position" + ( t *^ orig ^+^ (1-t) *^ ( u *^ pos0 ^+^ v *^ pos1 ^+^ w *^ pos2 ) ) diff --git a/test/Tests/Unicode/Syntax.hs b/test/Tests/Unicode/Syntax.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Unicode/Syntax.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnicodeSyntax #-} + +module Tests.Unicode.Syntax where + +-- fir +import FIR + +------------------------------------------------ +-- program + +type Defs = '[ "υβο" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] + ( Struct '[ "φ" ':-> Float ] ) + , "προϊόν" ':-> Output '[ Location 0 ] Float + , "κύριος" ':-> EntryPoint '[] Vertex + ] + +program :: Module Defs +program = Module $ entryPoint @"κύριος" @Vertex do + + φ <- use @(Name "υβο" :.: Name "φ") + δ₀ <- def @"δ₀" @R @Float $ 0.1 * φ + put @"προϊόν" δ₀ diff --git a/test/Tests/Vector/Applicative.hs b/test/Tests/Vector/Applicative.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Vector/Applicative.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Vector.Applicative where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- program + +type Defs = '[ "in_col1" ':-> Input '[Location 0] (V 3 Float) + , "in_col2" ':-> Input '[Location 1] (V 3 Float) + , "in_col3" ':-> Input '[Location 2] (V 3 Float) + , "out_col" ':-> Output '[Location 0] (V 3 Float) + , "main" ':-> EntryPoint '[OriginUpperLeft] Fragment + ] + +program :: Module Defs +program = Module do + + entryPoint @"main" @Fragment do + + in_col1 <- get @"in_col1" + in_col2 <- get @"in_col2" + in_col3 <- get @"in_col3" + + let func :: Code Float -> Code Float -> Code Float -> Code Float + func x y z = 2 * z - y + abs x + out_col :: Code (V 3 Float) + out_col = func <$$> in_col1 <**> in_col2 <**> in_col3 + + put @"out_col" out_col diff --git a/test/Tests/Vector/Functor.hs b/test/Tests/Vector/Functor.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Vector/Functor.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.Vector.Functor where + +-- fir +import FIR +import FIR.Syntax.Labels +import Math.Linear + +------------------------------------------------ +-- program + +type Defs + = '[ "ubo" ':-> Uniform '[ Binding 0, DescriptorSet 0 ] ( Struct '[ "mvp" ':-> M 4 4 Float ] ) + , "position" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "f" ':-> Function '[ "u" ':-> Var R Float ] Float + , "main" ':-> EntryPoint '[] Vertex + ] + + +program :: Module Defs +program = Module do + + (f :: Code Float -> Code Float) <- fundef @"f" do + u <- use @(Name "u") + t <- def @"t" @RW ( 11 :: Code Float ) -- local variable + pure (u + t) + + entryPoint @"main" @Vertex do + + mvp <- use @(Name "ubo" :.: Name "mvp") + position <- get @"position" + + ~(Vec4 x y z _) <- def @"pos" @R ( mvp !*^ (fmapAST (f . (*3) . f) position) ) + + #gl_Position .= Vec4 x z y 1 diff --git a/test/Tests/Vector/MixedSwizzle.golden b/test/Tests/Vector/MixedSwizzle.golden new file mode 100644 --- /dev/null +++ b/test/Tests/Vector/MixedSwizzle.golden @@ -0,0 +1,36 @@ +test/Tests/Vector/MixedSwizzle.hs:35:12: error: [GHC-64725] + • Cannot mix and match different swizzle sets. + Swizzle set of "g" is "rgba". + Swizzle set of "x" is "xyzw". + • In a stmt of a 'do' block: + col <- use @(Name "in_col" :.: Swizzle "rgxb") + In the third argument of ‘entryPoint’, namely + ‘do col <- use @(Name "in_col" :.: Swizzle "rgxb") + put @"out_col" col’ + In the second argument of ‘($)’, namely + ‘entryPoint + @"main" @Fragment + do col <- use @(Name "in_col" :.: Swizzle "rgxb") + put @"out_col" col’ + | +35 | col <- use @(Name "in_col" :.: Swizzle "rgxb") -- cannot mix "rgba" and "xyzw" + | ^^^ + +test/Tests/Vector/MixedSwizzle.hs:35:12: error: [GHC-64725] + • Cannot mix and match different swizzle sets. + Swizzle set of "g" is "rgba". + Swizzle set of "x" is "xyzw". + • In a stmt of a 'do' block: + col <- use @(Name "in_col" :.: Swizzle "rgxb") + In the third argument of ‘entryPoint’, namely + ‘do col <- use @(Name "in_col" :.: Swizzle "rgxb") + put @"out_col" col’ + In the second argument of ‘($)’, namely + ‘entryPoint + @"main" @Fragment + do col <- use @(Name "in_col" :.: Swizzle "rgxb") + put @"out_col" col’ + | +35 | col <- use @(Name "in_col" :.: Swizzle "rgxb") -- cannot mix "rgba" and "xyzw" + | ^^^ + diff --git a/test/Tests/Vector/MixedSwizzle.hs b/test/Tests/Vector/MixedSwizzle.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Vector/MixedSwizzle.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Tests.Vector.MixedSwizzle where + +-- fir +import FIR +import Math.Linear + +--------------------------------------------------------------------------------- + +type Defs = '[ "in_col" ':-> Input '[Location 0] (V 4 Float) + , "out_col" ':-> Output '[Location 0] (V 4 Float) + , "main" ':-> EntryPoint '[OriginUpperLeft] Fragment + ] + + +program :: Module Defs +program = Module $ entryPoint @"main" @Fragment do + + col <- use @(Name "in_col" :.: Swizzle "rgxb") -- cannot mix "rgba" and "xyzw" + + put @"out_col" col diff --git a/test/Tests/Vector/Swizzle.hs b/test/Tests/Vector/Swizzle.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Vector/Swizzle.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Tests.Vector.Swizzle where + +-- fir +import FIR +import Math.Linear + +--------------------------------------------------------------------------------- + +type Defs = '[ "in_col" ':-> Input '[Location 0] (V 4 Float) + , "out_col" ':-> Output '[Location 0] (V 3 Float) + , "main" ':-> EntryPoint '[OriginUpperLeft] Fragment + ] + +blue1 :: V 4 Float +blue1 = V4 0.2 0.8 1 1 + +darkGrey :: V 3 Float +darkGrey = view @(Swizzle "rrr") blue1 + +blue2 :: V 3 Float +blue2 = view @(Swizzle "rgb") blue1 + + +program :: Module Defs +program = Module $ entryPoint @"main" @Fragment do + + col1 <- use @(Name "in_col" :.: Swizzle "rgb") + col2 <- use @(Name "in_col") + let col3 = view @(Swizzle "bgr") col2 + col = 0.25 *^ ( col1 ^+^ col3 ^+^ Lit darkGrey ^+^ Lit blue2 ) + + r <- use @( Name "in_col" :.: Swizzle "r" ) + + + put @"out_col" col + + assign @(Name "out_col" :.: Index 1 ) r diff --git a/test/Tests/VertexInput/CompatibleTypes.golden b/test/Tests/VertexInput/CompatibleTypes.golden new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/CompatibleTypes.golden @@ -0,0 +1,1 @@ +No type-checking errors. diff --git a/test/Tests/VertexInput/CompatibleTypes.hs b/test/Tests/VertexInput/CompatibleTypes.hs new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/CompatibleTypes.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.VertexInput.CompatibleTypes where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- test implicit Int32 - Word32 conversion +-- between vertex input and vertex shader + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 4 Int32 ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Word32 ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + vec <- get @"in" + put @"out" ( ( convert :: Code Word32 -> Code Float ) <$$> vec ) + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/VertexInput/ComponentOutOfRange.golden b/test/Tests/VertexInput/ComponentOutOfRange.golden new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/ComponentOutOfRange.golden @@ -0,0 +1,18 @@ +test/Tests/VertexInput/ComponentOutOfRange.hs:38:10: error: [GHC-64725] + • Cannot position scalar of type Float + at Location 0, Component 4. + • In the expression: + shader + do ~(Vec4 x y z _) <- get @"in1" + w <- get @"in2" + put @"out" (Vec4 x y z w) + In an equation for ‘vertex’: + vertex + = shader + do ~(Vec4 x y z _) <- get @"in1" + w <- get @"in2" + put @"out" (Vec4 x y z w) + | +38 | vertex = shader do + | ^^^^^^ + diff --git a/test/Tests/VertexInput/ComponentOutOfRange.hs b/test/Tests/VertexInput/ComponentOutOfRange.hs new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/ComponentOutOfRange.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.VertexInput.ComponentOutOfRange where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- test vertex input specifying disallowed component +-- ( greater than 3 ) + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 4 Float + , Slot 0 4 ':-> Float + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in1" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "in2" ':-> Input '[ Location 0, Component 4 ] Float + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + ~(Vec4 x y z _) <- get @"in1" + w <- get @"in2" + put @"out" ( Vec4 x y z w ) + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/VertexInput/DoubleComponents.golden b/test/Tests/VertexInput/DoubleComponents.golden new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/DoubleComponents.golden @@ -0,0 +1,1 @@ +No type-checking errors. diff --git a/test/Tests/VertexInput/DoubleComponents.hs b/test/Tests/VertexInput/DoubleComponents.hs new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/DoubleComponents.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.VertexInput.DoubleComponents where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- test placing Doubles in various (valid) components + + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> Double + , Slot 0 2 ':-> Double + , Slot 1 0 ':-> V 2 Double + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in_x" ':-> Input '[ Location 0 ] Double + , "in_y" ':-> Input '[ Location 0, Component 2 ] Double + , "in_z" ':-> Input '[ Location 1 ] Double + , "in_w" ':-> Input '[ Location 1, Component 2 ] Double + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + x <- get @"in_x" + y <- get @"in_y" + z <- get @"in_z" + w <- get @"in_w" + put @"out" ( ( convert :: Code Double -> Code Float ) <$$> Vec4 x y z w ) + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/VertexInput/EquivalentComponents.golden b/test/Tests/VertexInput/EquivalentComponents.golden new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/EquivalentComponents.golden @@ -0,0 +1,1 @@ +No type-checking errors. diff --git a/test/Tests/VertexInput/EquivalentComponents.hs b/test/Tests/VertexInput/EquivalentComponents.hs new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/EquivalentComponents.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.VertexInput.EquivalentComponents where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- test splitting up / merging data +-- between vertex input and vertex shader input + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 3 Float, Slot 0 3 ':-> Float -- split1 + , Slot 1 0 ':-> V 3 Float, Slot 1 3 ':-> Float -- split2 + , Slot 2 0 ':-> V 4 Float -- nonsplit1 + , Slot 3 0 ':-> V 4 Float -- nonsplit2 + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in_split1a" ':-> Input '[ Location 0 ] ( V 3 Float ) + , "in_split1b" ':-> Input '[ Location 0, Component 3 ] Float + , "in_split2" ':-> Input '[ Location 1 ] ( V 4 Float ) + , "in_nonsplit1a" ':-> Input '[ Location 2 ] ( V 3 Float ) + , "in_nonsplit1b" ':-> Input '[ Location 2, Component 3 ] Float + , "in_nonsplit2" ':-> Input '[ Location 3 ] ( V 4 Float ) + + , "out_split1a" ':-> Output '[ Location 0 ] ( V 3 Float ) + , "out_split1b" ':-> Output '[ Location 0, Component 3 ] Float + , "out_split2" ':-> Output '[ Location 1 ] ( V 4 Float ) + , "out_nonsplit1a" ':-> Output '[ Location 2 ] ( V 3 Float ) + , "out_nonsplit1b" ':-> Output '[ Location 2, Component 3 ] Float + , "out_nonsplit2" ':-> Output '[ Location 3 ] ( V 4 Float ) + + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + + put @"out_split1a" =<< get @"in_split1a" + put @"out_split1b" =<< get @"in_split1b" + put @"out_split2" =<< get @"in_split2" + put @"out_nonsplit1a" =<< get @"in_nonsplit1a" + put @"out_nonsplit1b" =<< get @"in_nonsplit1b" + put @"out_nonsplit2" =<< get @"in_nonsplit2" + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in_split1a" ':-> Input '[ Location 0 ] ( V 3 Float ) + , "in_split1b" ':-> Input '[ Location 0, Component 3 ] Float + , "in_split2" ':-> Input '[ Location 1 ] ( V 4 Float ) + , "in_nonsplit1a" ':-> Input '[ Location 2 ] ( V 3 Float ) + , "in_nonsplit1b" ':-> Input '[ Location 2, Component 3 ] Float + , "in_nonsplit2" ':-> Input '[ Location 3 ] ( V 4 Float ) + , "out_colour" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out_colour" =<< get @"in_split2" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/VertexInput/IncompatibleTypes.golden b/test/Tests/VertexInput/IncompatibleTypes.golden new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/IncompatibleTypes.golden @@ -0,0 +1,1 @@ +Should error: expecting Float but given Int32, which are not compatible. diff --git a/test/Tests/VertexInput/IncompatibleTypes.hs b/test/Tests/VertexInput/IncompatibleTypes.hs new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/IncompatibleTypes.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.VertexInput.IncompatibleTypes where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- check that vertex input scalar types +-- match with vertex shader input +-- ( mismatch: Int32 vs Float ) + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 4 Int32 + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/VertexInput/IncompatibleWidths.golden b/test/Tests/VertexInput/IncompatibleWidths.golden new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/IncompatibleWidths.golden @@ -0,0 +1,1 @@ +Should error: expecting Float but given Double, which are not compatible. diff --git a/test/Tests/VertexInput/IncompatibleWidths.hs b/test/Tests/VertexInput/IncompatibleWidths.hs new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/IncompatibleWidths.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.VertexInput.IncompatibleWidths where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- check that vertex input scalar types +-- match with vertex shader input +-- ( mismatch: Float vs Double ) + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 2 Double + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/VertexInput/InvalidDoubleComponent.golden b/test/Tests/VertexInput/InvalidDoubleComponent.golden new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/InvalidDoubleComponent.golden @@ -0,0 +1,10 @@ +test/Tests/VertexInput/InvalidDoubleComponent.hs:37:10: error: [GHC-64725] + • Cannot position scalar of type Double + at Location 1, Component 1. + • In the expression: shader do put @"out" =<< get @"in" + In an equation for ‘vertex’: + vertex = shader do put @"out" =<< get @"in" + | +37 | vertex = shader do + | ^^^^^^ + diff --git a/test/Tests/VertexInput/InvalidDoubleComponent.hs b/test/Tests/VertexInput/InvalidDoubleComponent.hs new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/InvalidDoubleComponent.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.VertexInput.InvalidDoubleComponent where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- test placing Doubles in invalid (odd) components + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 4 Float + , Slot 1 1 ':-> Double + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "d" ':-> Input '[ Location 1, Component 1 ] Double + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/VertexInput/InvalidVectorComponent.golden b/test/Tests/VertexInput/InvalidVectorComponent.golden new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/InvalidVectorComponent.golden @@ -0,0 +1,10 @@ +test/Tests/VertexInput/InvalidVectorComponent.hs:39:10: error: [GHC-64725] + • Cannot position vector of type V 4 Float + at Location 0, Component 2. + • In the expression: shader do put @"out" =<< get @"in_yz" + In an equation for ‘vertex’: + vertex = shader do put @"out" =<< get @"in_yz" + | +39 | vertex = shader do + | ^^^^^^ + diff --git a/test/Tests/VertexInput/InvalidVectorComponent.hs b/test/Tests/VertexInput/InvalidVectorComponent.hs new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/InvalidVectorComponent.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.VertexInput.InvalidVectorComponent where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- test placing vectors in invalid components + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 2 Float + , Slot 0 2 ':-> V 4 Float + , Slot 1 2 ':-> V 2 Float + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in_x" ':-> Input '[ Location 0 ] ( V 2 Float ) + , "in_yz" ':-> Input '[ Location 0, Component 2 ] ( V 4 Float ) + , "in_w" ':-> Input '[ Location 1, Component 2 ] ( V 2 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + put @"out" =<< get @"in_yz" + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/VertexInput/MissingComponents.golden b/test/Tests/VertexInput/MissingComponents.golden new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/MissingComponents.golden @@ -0,0 +1,1 @@ +Should error: consuming location 0 components 0, 1, 2, 3, but only provided location 0 component 0 diff --git a/test/Tests/VertexInput/MissingComponents.hs b/test/Tests/VertexInput/MissingComponents.hs new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/MissingComponents.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.VertexInput.MissingComponents where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- test vertex shader accessing data +-- not specified in vertex input +-- ( validation should disallow this ) + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> Float ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/VertexInput/Overlap.golden b/test/Tests/VertexInput/Overlap.golden new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/Overlap.golden @@ -0,0 +1,38 @@ + +test\Tests\VertexInput\Overlap.hs:59:5: error: + * Overlap at Location 1, Component 0: + - V 4 Double with Location 0, Component 0, + - V 4 Float with Location 1, Component 0. + * In the expression: + ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex, "vertex.spv") + :>-> (fragment, "fragment.spv") + In an equation for `shaderPipeline': + shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex, "vertex.spv") + :>-> (fragment, "fragment.spv") + | +59 | = ShaderPipeline + | ^^^^^^^^^^^^^^^... + +test\Tests\VertexInput\Overlap.hs:59:5: error: + * Overlap at Location 1, Component 0: + - V 4 Double with Location 0, Component 0, + - V 4 Float with Location 1, Component 0. + * In the expression: + ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex, "vertex.spv") + :>-> (fragment, "fragment.spv") + In an equation for `shaderPipeline': + shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex, "vertex.spv") + :>-> (fragment, "fragment.spv") + | +59 | = ShaderPipeline + | ^^^^^^^^^^^^^^^... diff --git a/test/Tests/VertexInput/Overlap.hs b/test/Tests/VertexInput/Overlap.hs new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/Overlap.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.VertexInput.Overlap where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- check overlap in vertex input +-- ( V 4 Double spilling into next location slot ) + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 4 Double + , Slot 1 0 ':-> V 4 Float -- unused by the vertex shader but overlapping with the previous location + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Double ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + vec <- get @"in" + put @"out" ( ( convert :: Code Double -> Code Float ) <$$> vec ) + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv") diff --git a/test/Tests/VertexInput/V3Double_Double.golden b/test/Tests/VertexInput/V3Double_Double.golden new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/V3Double_Double.golden @@ -0,0 +1,1 @@ +No type-checking errors. diff --git a/test/Tests/VertexInput/V3Double_Double.hs b/test/Tests/VertexInput/V3Double_Double.hs new file mode 100644 --- /dev/null +++ b/test/Tests/VertexInput/V3Double_Double.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Tests.VertexInput.V3Double_Double where + +-- fir +import FIR +import Math.Linear + +------------------------------------------------ +-- check for valid placement of doubles + +------------------------------------------------ +-- pipeline input + +type VertexInput + = '[ Slot 0 0 ':-> V 3 Double + , Slot 1 2 ':-> Double + ] + +------------------------------------------------ +-- vertex shader + +type VertexDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Double ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ ] Vertex + ] + +vertex :: ShaderModule "main" VertexShader VertexDefs _ +vertex = shader do + v <- get @"in" + put @"out" ( ( convert :: Code Double -> Code Float ) <$$> v ) + +------------------------------------------------ +-- fragment shader + +type FragmentDefs = + '[ "in" ':-> Input '[ Location 0 ] ( V 4 Float ) + , "out" ':-> Output '[ Location 0 ] ( V 4 Float ) + , "main" ':-> EntryPoint '[ OriginUpperLeft ] Fragment + ] + +fragment :: ShaderModule "main" FragmentShader FragmentDefs _ +fragment = shader do + put @"out" =<< get @"in" + +------------------------------------------------ +-- pipeline + +shaderPipeline :: ShaderPipeline FilePath +shaderPipeline + = ShaderPipeline + $ StructInput @VertexInput @(Triangle List) + :>-> (vertex , "vertex.spv") + :>-> (fragment, "fragment.spv")