diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,1 +1,6 @@ # gpu-vulkan + +This package is still experimental. But examples are + +* https://github.com/YoshikuniJujo/test_haskell/tree/master/tribial/zenn/vulkan_blit/zenn-vulkan-blit-v1 +* https://github.com/YoshikuniJujo/test_haskell/tree/master/themes/gui/vulkan/try_using diff --git a/debug/Debug.hs b/debug/Debug.hs --- a/debug/Debug.hs +++ b/debug/Debug.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + module Debug where + +import Language.Haskell.TH + +runIO $ putStrLn "gpu-vulkan Debug: ************* DEBUG DEBUG DEBUG **************" >> pure [] debug = True diff --git a/gpu-vulkan.cabal b/gpu-vulkan.cabal --- a/gpu-vulkan.cabal +++ b/gpu-vulkan.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: gpu-vulkan -version: 0.1.0.142 +version: 0.1.0.153 synopsis: Vulkan library description: Please see the README on GitHub at category: GPU @@ -98,6 +98,9 @@ Gpu.Vulkan.Subpass Gpu.Vulkan.TypeEnum Gpu.Vulkan.VertexInput + Gpu.Vulkan.Sparse + Gpu.Vulkan.Sparse.Buffer + Gpu.Vulkan.Sparse.Image other-modules: Gpu.Vulkan.AllocationCallbacks.Type Gpu.Vulkan.Attachment.Enum @@ -172,6 +175,10 @@ Gpu.Vulkan.Sampler.Type Gpu.Vulkan.Semaphore.Type Gpu.Vulkan.ShaderModule.Internal + Gpu.Vulkan.Sparse.Buffer.Internal + Gpu.Vulkan.Sparse.Enum + Gpu.Vulkan.Sparse.Image.Internal + Gpu.Vulkan.Sparse.Internal Gpu.Vulkan.Subpass.Enum Gpu.Vulkan.TypeEnum.Th Gpu.Vulkan.TypeEnum.TypeValues @@ -185,7 +192,7 @@ , bytestring <1 , containers <1 , data-default <1 - , gpu-vulkan-middle <1 + , gpu-vulkan-middle >=0.1.0.60 && <1 , hetero-parameter-list <1 , hetero-parameter-list-with-typelevel-tools <1 , language-spir-v <1 @@ -225,7 +232,7 @@ , containers <1 , data-default <1 , gpu-vulkan - , gpu-vulkan-middle <1 + , gpu-vulkan-middle >=0.1.0.60 && <1 , hetero-parameter-list <1 , hetero-parameter-list-with-typelevel-tools <1 , language-spir-v <1 diff --git a/src/Gpu/Vulkan/Buffer.hs b/src/Gpu/Vulkan/Buffer.hs --- a/src/Gpu/Vulkan/Buffer.hs +++ b/src/Gpu/Vulkan/Buffer.hs @@ -33,6 +33,10 @@ MemoryBarrier(..), MemoryBarrierListToMiddle, + -- * UNSAFE + + unsafeToBinded, + -- * ENUM module Gpu.Vulkan.Buffer.Enum diff --git a/src/Gpu/Vulkan/Buffer/Internal.hs b/src/Gpu/Vulkan/Buffer/Internal.hs --- a/src/Gpu/Vulkan/Buffer/Internal.hs +++ b/src/Gpu/Vulkan/Buffer/Internal.hs @@ -36,7 +36,11 @@ -- * MEMORY BARRIER - MemoryBarrier(..), MemoryBarrierListToMiddle(..) + MemoryBarrier(..), MemoryBarrierListToMiddle(..), + + -- * UNSAFE + + unsafeToBinded ) where diff --git a/src/Gpu/Vulkan/Buffer/Type.hs b/src/Gpu/Vulkan/Buffer/Type.hs --- a/src/Gpu/Vulkan/Buffer/Type.hs +++ b/src/Gpu/Vulkan/Buffer/Type.hs @@ -34,3 +34,6 @@ deriving instance Eq (HeteroParList.PL VObj.Length objs) => Eq (Binded sm sb nm objs) + +unsafeToBinded :: B sb nm objs -> Binded sm sb nm objs +unsafeToBinded (B l b) = (Binded l b) diff --git a/src/Gpu/Vulkan/Device/Internal.hs b/src/Gpu/Vulkan/Device/Internal.hs --- a/src/Gpu/Vulkan/Device/Internal.hs +++ b/src/Gpu/Vulkan/Device/Internal.hs @@ -46,7 +46,7 @@ import qualified Gpu.Vulkan.PhysicalDevice as PhysicalDevice import qualified Gpu.Vulkan.Device.Middle as M import qualified Gpu.Vulkan.QueueFamily.Middle as QueueFamily -import qualified Gpu.Vulkan.Queue as Queue +import {-# SOURCE #-} qualified Gpu.Vulkan.Queue as Queue import Data.HeteroParList qualified as HeteroParList diff --git a/src/Gpu/Vulkan/Image.hs b/src/Gpu/Vulkan/Image.hs --- a/src/Gpu/Vulkan/Image.hs +++ b/src/Gpu/Vulkan/Image.hs @@ -31,6 +31,10 @@ Blit(..), SubresourceLayers(..), + -- * OTHERS + + Subresource(..), unsafeToBinded, + -- * ENUM module Gpu.Vulkan.Image.Enum diff --git a/src/Gpu/Vulkan/Image/Internal.hs b/src/Gpu/Vulkan/Image/Internal.hs --- a/src/Gpu/Vulkan/Image/Internal.hs +++ b/src/Gpu/Vulkan/Image/Internal.hs @@ -31,7 +31,11 @@ -- * BLIT - M.Blit(..), M.SubresourceLayers(..) + M.Blit(..), M.SubresourceLayers(..), + + -- * OTHERS + + M.Subresource(..), unsafeToBinded ) where diff --git a/src/Gpu/Vulkan/Image/Type.hs b/src/Gpu/Vulkan/Image/Type.hs --- a/src/Gpu/Vulkan/Image/Type.hs +++ b/src/Gpu/Vulkan/Image/Type.hs @@ -12,3 +12,6 @@ newtype I s (nm :: Symbol) (fmt :: T.Format) = I M.I newtype Binded sm si (nm :: Symbol) (fmt :: T.Format) = Binded M.I + +unsafeToBinded :: I si nm fmt -> Binded sm si hm fmt +unsafeToBinded (I i) = (Binded i) diff --git a/src/Gpu/Vulkan/Memory.hs b/src/Gpu/Vulkan/Memory.hs --- a/src/Gpu/Vulkan/Memory.hs +++ b/src/Gpu/Vulkan/Memory.hs @@ -46,9 +46,13 @@ M.Barrier(..), + -- * OTHERS + + RawOffset(..), + -- * ENUM - module Gpu.Vulkan.Memory.Enum + module Gpu.Vulkan.Memory.Enum, ) where @@ -242,16 +246,20 @@ M.allocateInfoMemoryTypeIndex = mti } memoryRequirementsListToSize :: - Device.M.Size -> [Maybe Device.M.Size] -> [M.Requirements] -> Device.M.Size + Device.M.Size -> [Maybe Device.M.Size] -> [Either AlgnSize M.Requirements] -> Device.M.Size memoryRequirementsListToSize sz0 _ [] = sz0 memoryRequirementsListToSize sz0 [] _ = sz0 -memoryRequirementsListToSize sz0 (malgn : malgns) (reqs : reqss) = +memoryRequirementsListToSize sz0 (malgn : malgns) (ereqs : reqss) = memoryRequirementsListToSize (((sz0 - 1) `div` algn + 1) * algn + sz) malgns reqss where - sz = M.requirementsSize reqs - algn = (fromMaybe 1 malgn) `lcm` - M.requirementsAlignment reqs + sz = case ereqs of + Left (_, s) -> s + Right reqs -> M.requirementsSize reqs + algn = case ereqs of + Left (a, _) -> a + Right reqs -> + (fromMaybe 1 malgn) `lcm` M.requirementsAlignment reqs -- READ AND WRITE diff --git a/src/Gpu/Vulkan/Memory/Bind.hs b/src/Gpu/Vulkan/Memory/Bind.hs --- a/src/Gpu/Vulkan/Memory/Bind.hs +++ b/src/Gpu/Vulkan/Memory/Bind.hs @@ -16,6 +16,8 @@ ) where +import Control.Monad + import Data.TypeLevel.Tuple.Uncurry import Data.HeteroParList qualified as HeteroParList import Data.HeteroParList (pattern (:**)) @@ -32,6 +34,10 @@ import Gpu.Vulkan.Memory.Type +import Gpu.Vulkan.Object qualified as VObj + +import Debug + class (BindAll ibargs ibargs, Alignments ibargs) => Bindable ibargs instance (BindAll ibargs ibargs , Alignments ibargs) => Bindable ibargs @@ -47,20 +53,31 @@ bindAll dv@(Device.D mdv) (U2 ii@(Image (Image.I i)) :** ibs) m ost = do (_, mm) <- readM m (ost', sz) <- adjustOffsetSize dv ii ost + when debug . putStrLn $ "Gpu.Vulkan.Memory.Bind.BindAll (ImageArg): (ost', sz) = " ++ show (ost', sz) Image.M.bindMemory mdv i mm ost' (U2 (ImageBinded $ Image.Binded i) :**) <$> bindAll dv ibs m (ost' + sz) -instance BindAll ibargs mibargs => - BindAll ('(sb, ('BufferArg nm objs)) ': ibargs) mibargs where +instance (VObj.SizeAlignment obj, BindAll ibargs mibargs) => + BindAll ('(sb, ('BufferArg nm (obj ': objs))) ': ibargs) mibargs where bindAll dv@(Device.D mdv) (U2 bb@(Buffer (Buffer.B lns b)) :** ibs) m ost = do (_, mm) <- readM m (ost', sz) <- adjustOffsetSize dv bb ost - Buffer.M.bindMemory mdv b mm ost' + let ost'' = adjust (VObj.alignment @obj) ost' + when debug . putStrLn $ "Gpu.Vulkan.Memory.Bind.BindAll (BufferArg): " ++ show (ost', sz) + when debug . putStrLn $ "Gpu.Vulkan.Memory.Bind.BindAll (BufferArg): ost'' = " ++ show ost'' + Buffer.M.bindMemory mdv b mm ost'' (U2 (BufferBinded $ Buffer.Binded lns b) :**) - <$> bindAll dv ibs m (ost' + sz) + <$> bindAll dv ibs m (ost'' + sz) +instance BindAll ibargs mibargs => + BindAll ('(sb, 'RawArg) ': ibargs) mibargs where + bindAll dv (U2 bb@(Raw a s) :** ibs) m ost = do + (ost', sz) <- adjustOffsetSize dv bb ost + when debug . putStrLn $ "Gpu.Vulkan.Memory.Bind.BindAll (RawArg): " ++ show (ost', sz) + (U2 (RawBinded a s) :**) <$> bindAll dv ibs m (ost' + sz) + class (RebindAll ibargs ibargs, Alignments ibargs) => Rebindable ibargs instance (RebindAll ibargs ibargs, Alignments ibargs) => Rebindable ibargs @@ -87,4 +104,10 @@ (_, mm) <- readM m (ost', sz) <- adjustOffsetSizeBinded dv bb ost Buffer.M.bindMemory mdv b mm ost' + rebindAll dv ibs m $ ost' + sz + +instance RebindAll ibargs mibargs => + RebindAll ('(sb, 'RawArg) ': ibargs) mibargs where + rebindAll dv (U2 bb :** ibs) m ost = do + (ost', sz) <- adjustOffsetSizeBinded dv bb ost rebindAll dv ibs m $ ost' + sz diff --git a/src/Gpu/Vulkan/Memory/ImageBuffer.hs b/src/Gpu/Vulkan/Memory/ImageBuffer.hs --- a/src/Gpu/Vulkan/Memory/ImageBuffer.hs +++ b/src/Gpu/Vulkan/Memory/ImageBuffer.hs @@ -7,7 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE PatternSynonyms, ViewPatterns #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-tabs #-} module Gpu.Vulkan.Memory.ImageBuffer ( @@ -30,8 +30,16 @@ -- * FOR READ AND WRITE - ObjectLength(..) + ObjectLength(..), + -- * OTHERS + + AlgnSize, adjust, + + -- * RAW OFFSET + + RawOffset(..), RawOffsetToOffset(..) + ) where import Prelude hiding (map, read) @@ -47,6 +55,7 @@ import qualified Gpu.Vulkan.TypeEnum as T +import qualified Gpu.Vulkan.Device as Device import qualified Gpu.Vulkan.Device.Type as Device import qualified Gpu.Vulkan.Device.Middle as Device.M @@ -54,11 +63,14 @@ import qualified Gpu.Vulkan.Buffer.Middle as Buffer.M import qualified Gpu.Vulkan.Memory.Middle as Memory.M +import qualified Data.HeteroParList as HPList + -- IMAGE BUFFER data ImageBuffer s (ibarg :: ImageBufferArg) where Image :: Image.I si nm fmt -> ImageBuffer si ('ImageArg nm fmt) Buffer :: Buffer.B sb nm objs -> ImageBuffer sb ('BufferArg nm objs) + Raw :: Device.M.Size -> Device.M.Size -> ImageBuffer s RawArg deriving instance Show (HeteroParList.PL VObj.Length objs) => Show (ImageBuffer sib ('BufferArg nm objs)) @@ -68,51 +80,62 @@ ImageBufferBinded sm si ('ImageArg nm fmt) BufferBinded :: Buffer.Binded sm sb nm objs -> ImageBufferBinded sm sb ('BufferArg nm objs) + RawBinded :: Device.M.Size -> Device.M.Size -> + ImageBufferBinded sm sb RawArg deriving instance Show (HeteroParList.PL VObj.Length objs) => Show (ImageBufferBinded sm sib ('BufferArg nm objs)) -data ImageBufferArg = ImageArg Symbol T.Format | BufferArg Symbol [VObj.O] +data ImageBufferArg = + ImageArg Symbol T.Format | BufferArg Symbol [VObj.O] | RawArg -- GET REQUIREMENTS LIST -getRequirementsList :: Device.D sd -> - HeteroParList.PL (U2 ImageBuffer) ibargs -> IO [Memory.M.Requirements] +type AlgnSize = (Device.M.Size, Device.M.Size) + +getRequirementsList :: + Device.D sd -> HeteroParList.PL (U2 ImageBuffer) ibargs -> + IO [Either AlgnSize Memory.M.Requirements] getRequirementsList dv = HeteroParList.toListM \(U2 bi) -> getMemoryRequirements dv bi getRequirementsListBinded :: Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs -> - IO [Memory.M.Requirements] + IO [Either AlgnSize Memory.M.Requirements] getRequirementsListBinded dv = HeteroParList.toListM \(U2 bi) -> getMemoryRequirementsBinded dv bi getMemoryRequirements :: - Device.D sd -> ImageBuffer sib fos -> IO Memory.M.Requirements + Device.D sd -> ImageBuffer sib fos -> IO (Either AlgnSize Memory.M.Requirements) getMemoryRequirements (Device.D dv) = \case - Buffer (Buffer.B _ b) -> Buffer.M.getMemoryRequirements dv b - Image (Image.I i) -> Image.M.getMemoryRequirements dv i + Buffer (Buffer.B _ b) -> Right <$> Buffer.M.getMemoryRequirements dv b + Image (Image.I i) -> Right <$> Image.M.getMemoryRequirements dv i + Raw algn sz -> pure $ Left (algn, sz) getMemoryRequirementsBinded :: - Device.D sd -> ImageBufferBinded sm sib fos -> IO Memory.M.Requirements + Device.D sd -> ImageBufferBinded sm sib fos -> IO (Either AlgnSize Memory.M.Requirements) getMemoryRequirementsBinded (Device.D dv) = \case - BufferBinded (Buffer.Binded _ b) -> Buffer.M.getMemoryRequirements dv b - ImageBinded (Image.Binded i) -> Image.M.getMemoryRequirements dv i + BufferBinded (Buffer.Binded _ b) -> Right <$> Buffer.M.getMemoryRequirements dv b + ImageBinded (Image.Binded i) -> Right <$> Image.M.getMemoryRequirements dv i + RawBinded algn sz -> pure $ Left (algn, sz) -- ADJUST OFFSET AND GET SIZE adjustOffsetSize :: Device.D sd -> ImageBuffer sib ibarg -> Device.M.Size -> IO (Device.M.Size, Device.M.Size) -adjustOffsetSize dv ib ost = (<$> getMemoryRequirements dv ib) \rs -> ( - adjust (Memory.M.requirementsAlignment rs) ost, - Memory.M.requirementsSize rs ) +adjustOffsetSize dv ib ost = (<$> getMemoryRequirements dv ib) \case + Right rs -> ( + adjust (Memory.M.requirementsAlignment rs) ost, + Memory.M.requirementsSize rs ) + Left (algn, sz) -> (adjust algn ost, sz) adjustOffsetSizeBinded :: Device.D sd -> ImageBufferBinded sm sib ibarg -> Device.M.Size -> IO (Device.M.Size, Device.M.Size) -adjustOffsetSizeBinded dv ib ost = - (<$> getMemoryRequirementsBinded dv ib) \rs -> ( +adjustOffsetSizeBinded dv ib ost = (<$> getMemoryRequirementsBinded dv ib) \case + Right rs -> ( adjust (Memory.M.requirementsAlignment rs) ost, Memory.M.requirementsSize rs ) + Left (algn, sz) -> (adjust algn ost, sz) adjust :: Device.M.Size -> Device.M.Size -> Device.M.Size adjust algn ost = ((ost - 1) `div` algn + 1) * algn @@ -131,6 +154,9 @@ Alignments ('(_s, 'BufferArg _nm objs) ': ibs) where alignments = Just (VObj.wholeAlign @objs) : alignments @ibs +instance Alignments ibs => Alignments ('(_s, 'RawArg) ': ibs) where + alignments = Nothing : alignments @ibs + -- OBJECT LENGTH class ObjectLength (nm :: Symbol) (obj :: VObj.O) ibargs where @@ -145,3 +171,27 @@ instance {-# OVERLAPPABLE #-} ObjectLength nm obj ibargs => ObjectLength nm obj (ibarg ': ibargs) where objectLength' (_ :** lns) = objectLength' @nm @obj lns + +-- RAW OFFSET + +class RawOffsetToOffset ibargs (n :: Nat) where + rawOffsetToOffset :: Device.Size -> Device.D sd -> + HPList.PL (U2 ImageBuffer) ibargs -> RawOffset n -> + IO Device.Size + +instance RawOffsetToOffset ('(sr, RawArg) ': ibargs) 0 where + rawOffsetToOffset ost0 _ _ (RawOffset o) = pure $ ost0 + o + +instance {-# OVERLAPPABLE #-} RawOffsetToOffset ibargs (n - 1) => + RawOffsetToOffset ('(sr, RawArg) ': ibargs) n where + rawOffsetToOffset ost0 dv (U2 ib :** ibs) (RawOffset o) = do + (ost', sz) <- adjustOffsetSize dv ib ost0 + rawOffsetToOffset (ost' + sz) dv ibs (RawOffset @(n - 1) o) + +instance {-# OVERLAPPABLE #-} RawOffsetToOffset ibargs n => + RawOffsetToOffset (ibarg ': ibargs) n where + rawOffsetToOffset ost0 dv (U2 ib :** ibs) ro = do + (ost', sz) <- adjustOffsetSize dv ib ost0 + rawOffsetToOffset (ost' + sz) dv ibs ro + +newtype RawOffset (n :: Nat) = RawOffset Device.Size deriving (Show, Num) diff --git a/src/Gpu/Vulkan/Memory/Type.hs b/src/Gpu/Vulkan/Memory/Type.hs --- a/src/Gpu/Vulkan/Memory/Type.hs +++ b/src/Gpu/Vulkan/Memory/Type.hs @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-tabs #-} module Gpu.Vulkan.Memory.Type ( @@ -23,8 +24,12 @@ -- * OBJECT LENGTH - objectLength + objectLength, + -- * RAW OFFSET + + RawOffset, rawOffset, RawOffsetToOffset + ) where import Data.Kind @@ -39,6 +44,8 @@ import Gpu.Vulkan.Memory.ImageBuffer import Gpu.Vulkan.Memory.Middle qualified as M +import Gpu.Vulkan.Device.Internal qualified as Device + -- MEMORY data M s (ibargs :: [(Type, ImageBufferArg)]) = @@ -55,6 +62,7 @@ toBinded :: U2 ImageBuffer ibarg -> U2 (ImageBufferBinded sm) ibarg toBinded (U2 (Image (I.I i))) = U2 . ImageBinded $ I.Binded i toBinded (U2 (Buffer (B.B x b))) = U2 . BufferBinded $ B.Binded x b + toBinded (U2 (Raw algn sz)) = U2 $ RawBinded algn sz readM :: M s ibargs -> IO (HeteroParList.PL (U2 ImageBuffer) ibargs, M.M) readM (M ib m) = (, m) <$> readIORef ib @@ -67,9 +75,18 @@ fromBinded :: U2 (ImageBufferBinded sm) ibarg -> U2 ImageBuffer ibarg fromBinded (U2 (ImageBinded (I.Binded i))) = U2 . Image $ I.I i fromBinded (U2 (BufferBinded (B.Binded x b))) = U2 . Buffer $ B.B x b + fromBinded (U2 (RawBinded algn sz)) = U2 $ Raw algn sz -- OBJECT LENGTH objectLength :: forall nm obj ibargs sm . ObjectLength nm obj ibargs => M sm ibargs -> IO (VObj.Length obj) objectLength m = (<$> readM m) \(ibs, _m) -> objectLength' @nm @obj @ibargs ibs + +-- RAW OFFSET + +rawOffset :: RawOffsetToOffset ibargs n => + Device.D sd -> M sm ibargs -> RawOffset n -> IO Device.Size +rawOffset dv (M ribs _) ro = do + ibs <- readIORef ribs + rawOffsetToOffset 0 dv ibs ro diff --git a/src/Gpu/Vulkan/Object.hs b/src/Gpu/Vulkan/Object.hs --- a/src/Gpu/Vulkan/Object.hs +++ b/src/Gpu/Vulkan/Object.hs @@ -82,6 +82,10 @@ SizeAlignmentList(..), SizeAlignment(..), + -- ** Others + + alignment + ) where import Prelude hiding (length) diff --git a/src/Gpu/Vulkan/Queue.hs b/src/Gpu/Vulkan/Queue.hs --- a/src/Gpu/Vulkan/Queue.hs +++ b/src/Gpu/Vulkan/Queue.hs @@ -1,4 +1,9 @@ {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} {-# OPTIONS_GHC -Wall -fno-warn-tabs #-} module Gpu.Vulkan.Queue ( @@ -11,6 +16,10 @@ Index, + -- * SPARSE RESOURCES + + bindSparse, BindSparseInfo(..), BindSparseInfosToMiddle, + -- * ENUM module Gpu.Vulkan.Queue.Enum @@ -18,6 +27,7 @@ ) where import Data.TypeLevel.Tuple.Uncurry +import Data.TypeLevel.Tuple.MapIndex import Data.HeteroParList qualified as HeteroParList import Data.Word @@ -28,9 +38,97 @@ import Gpu.Vulkan.Queue.Middle qualified as M import Gpu.Vulkan.Queue.Enum +import Data.TypeLevel.Maybe qualified as TMaybe +import Data.HeteroParList (pattern (:**)) +import Data.HeteroParList qualified as HPList + +import Foreign.Storable.PeekPoke +import Gpu.Vulkan.Device qualified as Device +import Gpu.Vulkan.Semaphore.Internal qualified as Semaphore +import Gpu.Vulkan.Sparse.Buffer.Internal qualified as Sparse.Buffer +import Gpu.Vulkan.Sparse.Image.Internal qualified as Sparse.Image + +import Control.Monad +import Debug + submit :: SubmitInfoListToMiddle sias => M.Q -> HeteroParList.PL (U4 SubmitInfo) sias -> Maybe (Fence.F sf) -> IO () submit q sis mf = M.submit q (submitInfoListToMiddle sis) $ (\(Fence.F f) -> f) <$> mf type Index = Word32 + +bindSparse :: ( + BindSparseInfosToMiddle ias, + HPList.ToListWithCCpsM' WithPoked TMaybe.M (M0_6 ias) ) => + Device.D sd -> M.Q -> + HPList.PL (U6 BindSparseInfo) ias -> Maybe (Fence.F sf) -> IO () +bindSparse dv q is mf = do + let mmf = case mf of + Just (Fence.F f) -> Just f + Nothing -> Nothing + when debug $ putStrLn + "Gpu.Vulkan.Queue.bindSparse: before bindSparseInfoToMiddle" + mis <- bindSparseInfosToMiddle dv is + when debug $ putStrLn + "Gpu.Vulkan.Queue.bindSparse: before M.bindSparse" + M.bindSparse q mis mmf + +data BindSparseInfo mn swss bbs iobs ibs ssss = BindSparseInfo { + bindSparseInfoNext :: TMaybe.M mn, + bindSparseInfoWaitSemaphores :: HPList.PL Semaphore.S swss, + bindSparseInfoBufferBinds :: + HPList.PL (U4 Sparse.Buffer.MemoryBindInfo) bbs, + bindSparseInfoImageOpaqueBinds :: + HPList.PL (U4 Sparse.Image.OpaqueMemoryBindInfo) iobs, + bindSparseInfoImageBinds :: + HPList.PL (U4 Sparse.Image.MemoryBindInfo) ibs, + bindSparseInfoSignalSemaphores :: HPList.PL Semaphore.S ssss } + +bindSparseInfoToMiddle :: ( + Sparse.Buffer.MemoryBindInfosToMiddle bbs, + Sparse.Image.OpaqueMemoryBindInfosToMiddle iobs, + Sparse.Image.MemoryBindInfosToMiddle ibs ) => + Device.D sd -> + BindSparseInfo mn swss bbs iobs ibs ssss -> IO (M.BindSparseInfo mn) +bindSparseInfoToMiddle dv BindSparseInfo { + bindSparseInfoNext = mn, + bindSparseInfoWaitSemaphores = + HPList.toList (\(Semaphore.S s) -> s) -> wss, + bindSparseInfoBufferBinds = bbs, + bindSparseInfoImageOpaqueBinds = iobs, + bindSparseInfoImageBinds = ibs, + bindSparseInfoSignalSemaphores = + HPList.toList (\(Semaphore.S s) -> s) -> sss + } = do + mbbs <- Sparse.Buffer.memoryBindInfosToMiddle dv bbs + miobs <- Sparse.Image.opaqueMemoryBindInfosToMiddle dv iobs + mibs <- Sparse.Image.memoryBindInfosToMiddle dv ibs + pure M.BindSparseInfo { + M.bindSparseInfoNext = mn, + M.bindSparseInfoWaitSemaphores = wss, + M.bindSparseInfoBufferBinds = mbbs, + M.bindSparseInfoImageOpaqueBinds = miobs, + M.bindSparseInfoImageBinds = mibs, + M.bindSparseInfoSignalSemaphores = sss } + +class BindSparseInfosToMiddle bsias where + bindSparseInfosToMiddle :: Device.D sd -> + HPList.PL (U6 BindSparseInfo) bsias -> + IO (HPList.PL M.BindSparseInfo (M0_6 bsias)) + +instance BindSparseInfosToMiddle '[] where + bindSparseInfosToMiddle _ HPList.Nil = pure HPList.Nil + +instance ( + Sparse.Buffer.MemoryBindInfosToMiddle bbs, + Sparse.Image.OpaqueMemoryBindInfosToMiddle iobs, + Sparse.Image.MemoryBindInfosToMiddle ibs, + BindSparseInfosToMiddle bsias ) => + BindSparseInfosToMiddle + ('(mn, swss, bbs, iobs, ibs, ssss) ': bsias) where + bindSparseInfosToMiddle dv (U6 i :** is) = (:**) + <$> bindSparseInfoToMiddle dv i + <*> bindSparseInfosToMiddle dv is + +-- instance BindSparse diff --git a/src/Gpu/Vulkan/Queue.hs-boot b/src/Gpu/Vulkan/Queue.hs-boot new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Queue.hs-boot @@ -0,0 +1,6 @@ +module Gpu.Vulkan.Queue (Q, Index) where + +import Data.Word +import Gpu.Vulkan.Queue.Middle + +type Index = Word32 diff --git a/src/Gpu/Vulkan/Sparse.hs b/src/Gpu/Vulkan/Sparse.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Sparse.hs @@ -0,0 +1,3 @@ +module Gpu.Vulkan.Sparse (MemoryBind(..)) where + +import Gpu.Vulkan.Sparse.Internal diff --git a/src/Gpu/Vulkan/Sparse/Buffer.hs b/src/Gpu/Vulkan/Sparse/Buffer.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Sparse/Buffer.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Sparse.Buffer (MemoryBindInfo(..)) where + +import Gpu.Vulkan.Sparse.Buffer.Internal diff --git a/src/Gpu/Vulkan/Sparse/Buffer/Internal.hs b/src/Gpu/Vulkan/Sparse/Buffer/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Sparse/Buffer/Internal.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGe PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Sparse.Buffer.Internal where + +import Data.TypeLevel.Tuple.Uncurry +import Data.HeteroParList (pattern (:**)) +import Data.HeteroParList qualified as HPList + +import Gpu.Vulkan.Device qualified as Device +import Gpu.Vulkan.Buffer.Type qualified as Buffer +import Gpu.Vulkan.Sparse.Internal + +import Gpu.Vulkan.Sparse.Buffer.Middle qualified as M + +data MemoryBindInfo sb bnm objs sais = MemoryBindInfo { + memoryBindInfoBuffer :: Buffer.B sb bnm objs, + memoryBindInfoBinds :: HPList.PL (U3 MemoryBind) sais } + +memoryBindInfoToMiddle :: MemoryBindsToMiddle sais => + Device.D sd -> MemoryBindInfo sb bnm objs sais -> IO M.MemoryBindInfo +memoryBindInfoToMiddle dv MemoryBindInfo { + memoryBindInfoBuffer = Buffer.B _ b, + memoryBindInfoBinds = bs + } = do + mbs <- memoryBindsToMiddle dv bs + pure M.MemoryBindInfo { + M.memoryBindInfoBuffer = b, + M.memoryBindInfoBinds = mbs } + +class MemoryBindInfosToMiddle mbias where + memoryBindInfosToMiddle :: + Device.D sd -> + HPList.PL (U4 MemoryBindInfo) mbias -> IO [M.MemoryBindInfo] + +instance MemoryBindInfosToMiddle '[] where + memoryBindInfosToMiddle _ HPList.Nil = pure [] + +instance (MemoryBindsToMiddle sais, MemoryBindInfosToMiddle mbias) => + MemoryBindInfosToMiddle ('(sb, bnm, objs, sais) ': mbias) where + memoryBindInfosToMiddle dv (U4 mbi :** mbis) = (:) + <$> memoryBindInfoToMiddle dv mbi + <*> memoryBindInfosToMiddle dv mbis + +{- +memoryBindInfosToMiddle :: + HPList.ToListWithCM' MemoryBindsToMiddle I3_4 mbias => + Device.D sd -> HPList.PL (U4 MemoryBindInfo) mbias -> IO [M.MemoryBindInfo] +memoryBindInfosToMiddle dv = toListWithCM' (\U4 mbi -> memoryBindInfoToMiddle dv mbi) +-} diff --git a/src/Gpu/Vulkan/Sparse/Enum.hs b/src/Gpu/Vulkan/Sparse/Enum.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Sparse/Enum.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PackageImports #-} + +module Gpu.Vulkan.Sparse.Enum (module Gpu.Vulkan.Sparse.Enum) where + +import "gpu-vulkan-middle" Gpu.Vulkan.Sparse.Enum diff --git a/src/Gpu/Vulkan/Sparse/Image.hs b/src/Gpu/Vulkan/Sparse/Image.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Sparse/Image.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Sparse.Image ( + OpaqueMemoryBindInfo(..), MemoryBindInfo(..), MemoryBind(..) ) where + +import Gpu.Vulkan.Sparse.Image.Internal diff --git a/src/Gpu/Vulkan/Sparse/Image/Internal.hs b/src/Gpu/Vulkan/Sparse/Image/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Sparse/Image/Internal.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Sparse.Image.Internal where + +import Data.TypeLevel.Tuple.Uncurry +import Data.HeteroParList (pattern (:**)) +import Data.HeteroParList qualified as HPList + +import Gpu.Vulkan.Internal +import Gpu.Vulkan.Device.Internal qualified as Device +import Gpu.Vulkan.Memory.Type qualified as Memory +import Gpu.Vulkan.Image.Internal qualified as Image +import Gpu.Vulkan.Sparse.Internal qualified as S + +import Gpu.Vulkan.Sparse.Enum qualified as S +import Gpu.Vulkan.Sparse.Image.Middle qualified as M + +data OpaqueMemoryBindInfo si inm fmt sais = OpaqueMemoryBindInfo { + opaqueMemoryBindInfoImage :: Image.I si inm fmt, + opaqueMemoryBindInfoBinds :: HPList.PL (U3 S.MemoryBind) sais } + +opaqueMemoryBindInfoToMiddle :: S.MemoryBindsToMiddle sais => + Device.D sd -> OpaqueMemoryBindInfo si inm fmt sais -> + IO M.OpaqueMemoryBindInfo +opaqueMemoryBindInfoToMiddle dv OpaqueMemoryBindInfo { + opaqueMemoryBindInfoImage = Image.I i, + opaqueMemoryBindInfoBinds = bs } = do + mbs <- S.memoryBindsToMiddle dv bs + pure M.OpaqueMemoryBindInfo { + M.opaqueMemoryBindInfoImage = i, + M.opaqueMemoryBindInfoBinds = mbs } + +class OpaqueMemoryBindInfosToMiddle ombias where + opaqueMemoryBindInfosToMiddle :: + Device.D sd -> HPList.PL (U4 OpaqueMemoryBindInfo) ombias -> + IO [M.OpaqueMemoryBindInfo] + +instance OpaqueMemoryBindInfosToMiddle '[] where + opaqueMemoryBindInfosToMiddle _ HPList.Nil = pure [] + +instance (S.MemoryBindsToMiddle sais, OpaqueMemoryBindInfosToMiddle ombias) => + OpaqueMemoryBindInfosToMiddle ('(si, inm, fmt, sais) ': ombias) where + opaqueMemoryBindInfosToMiddle dv (U4 ombi :** ombis) = (:) + <$> opaqueMemoryBindInfoToMiddle dv ombi + <*> opaqueMemoryBindInfosToMiddle dv ombis + +data MemoryBindInfo si inm fmt sais = MemoryBindInfo { + memoryBindInfoImage :: Image.I si inm fmt, + memoryBindInfoBinds :: HPList.PL (U3 MemoryBind) sais } + +memoryBindInfoToMiddle :: MemoryBindsToMiddle sais => + Device.D sd -> MemoryBindInfo si inm fmt sais -> IO M.MemoryBindInfo +memoryBindInfoToMiddle dv MemoryBindInfo { + memoryBindInfoImage = Image.I mi, + memoryBindInfoBinds = bs + } = do + mbs <- memoryBindsToMiddle dv bs + pure M.MemoryBindInfo { + M.memoryBindInfoImage = mi, + M.memoryBindInfoBinds = mbs } + +class MemoryBindInfosToMiddle mbias where + memoryBindInfosToMiddle :: + Device.D sd -> + HPList.PL (U4 MemoryBindInfo) mbias -> IO [M.MemoryBindInfo] + +instance MemoryBindInfosToMiddle '[] where + memoryBindInfosToMiddle _ HPList.Nil = pure [] + +instance (MemoryBindsToMiddle sais, MemoryBindInfosToMiddle mbias) => + MemoryBindInfosToMiddle ('(si, inm, fmt, sais) ': mbias) where + memoryBindInfosToMiddle dv (U4 mbi :** mbis) = (:) + <$> memoryBindInfoToMiddle dv mbi + <*> memoryBindInfosToMiddle dv mbis + +data MemoryBind sm ibargs i = MemoryBind { + memoryBindSubresource :: Image.Subresource, + memoryBindOffset :: Offset3d, + memoryBindExtent :: Extent3d, + memoryBindMemory :: Memory.M sm ibargs, + memoryBindMemoryOffset :: Memory.RawOffset i, + memoryBindFlags :: S.MemoryBindFlags } + +memoryBindToMiddle :: Memory.RawOffsetToOffset ibargs i => + Device.D sd -> MemoryBind sm ibargs i -> IO M.MemoryBind +memoryBindToMiddle dv MemoryBind { + memoryBindSubresource = sr, + memoryBindOffset = ost, + memoryBindExtent = ex, + memoryBindMemory = m@(Memory.M _ mm), + memoryBindMemoryOffset = most, + memoryBindFlags = fs + } = do + mmo <- Memory.rawOffset dv m most + pure M.MemoryBind { + M.memoryBindSubresource = sr, + M.memoryBindOffset = ost, + M.memoryBindExtent = ex, + M.memoryBindMemory = mm, + M.memoryBindMemoryOffset = mmo, + M.memoryBindFlags = fs } + +class MemoryBindsToMiddle sais where + memoryBindsToMiddle :: + Device.D sd -> HPList.PL (U3 MemoryBind) sais -> IO [M.MemoryBind] + +instance MemoryBindsToMiddle '[] where + memoryBindsToMiddle _ HPList.Nil = pure [] + +instance (Memory.RawOffsetToOffset ibargs i, MemoryBindsToMiddle sais) => + MemoryBindsToMiddle ('(sm, ibargs, i) ': sais) where + memoryBindsToMiddle dv (U3 mb :** mbs) = (:) + <$> memoryBindToMiddle dv mb + <*> memoryBindsToMiddle dv mbs diff --git a/src/Gpu/Vulkan/Sparse/Internal.hs b/src/Gpu/Vulkan/Sparse/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Gpu/Vulkan/Sparse/Internal.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Gpu.Vulkan.Sparse.Internal where + +import Data.TypeLevel.Tuple.Uncurry +import Data.HeteroParList (pattern (:**)) +import Data.HeteroParList qualified as HPList + +import Gpu.Vulkan.Device qualified as Device +import Gpu.Vulkan.Memory.Type qualified as Memory +import Gpu.Vulkan.Sparse.Enum + +import Gpu.Vulkan.Sparse.Middle qualified as M + +data MemoryBind sm ibargs i = MemoryBind { + memoryBindResourceOffset :: Device.Size, + memoryBindSize :: Device.Size, + memoryBindMemory :: Memory.M sm ibargs, + memoryBindMemoryOffset :: Memory.RawOffset i, + memoryBindFlags :: MemoryBindFlags } + +memoryBindToMiddle :: Memory.RawOffsetToOffset ibargs i => + Device.D sd -> MemoryBind sm ibargs i -> IO M.MemoryBind +memoryBindToMiddle dv MemoryBind { + memoryBindResourceOffset = rsco, + memoryBindSize = sz, + memoryBindMemory = m@(Memory.M _ mm), + memoryBindMemoryOffset = rwo, + memoryBindFlags = fs } = do + mo <- Memory.rawOffset dv m rwo + pure M.MemoryBind { + M.memoryBindResourceOffset = rsco, + M.memoryBindSize = sz, + M.memoryBindMemory = mm, + M.memoryBindMemoryOffset = mo, + M.memoryBindFlags = fs } + +class MemoryBindsToMiddle sais where + memoryBindsToMiddle :: + Device.D sd -> HPList.PL (U3 MemoryBind) sais -> IO [M.MemoryBind] + +instance MemoryBindsToMiddle '[] where + memoryBindsToMiddle _ HPList.Nil = pure [] + +instance (Memory.RawOffsetToOffset ibargs i, MemoryBindsToMiddle sais) => + MemoryBindsToMiddle ('(sm, ibargs, i) ': sais) where + memoryBindsToMiddle dv (U3 mb :** mbs) = (:) + <$> memoryBindToMiddle dv mb + <*> memoryBindsToMiddle dv mbs