{-# LINE 1 "src/Gpu/Vulkan/Device/Middle/Internal.hsc" #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RankNTypes, TypeApplications #-}
{-# LANGUAGE GADTs, TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}
module Gpu.Vulkan.Device.Middle.Internal (
create, destroy, D(..), CreateInfo(..), CreateFlags, CreateFlagBits,
QueueCreateInfo(..),
getQueue, waitIdle,
Size(..)
) where
import Foreign.Ptr
import Foreign.Marshal
import Foreign.Storable
import Foreign.Storable.PeekPoke (
WithPoked, withPoked', withPtrS, pattern NullPtr )
import Foreign.Storable.HeteroList
import Foreign.C.Enum
import Control.Arrow
import Control.Monad.Cont
import Data.TypeLevel.Maybe qualified as TMaybe
import Data.TypeLevel.ParMaybe qualified as TPMaybe
import Data.Default
import Data.Bits
import Data.List (genericLength)
import Data.HeteroParList qualified as HeteroParList
import Data.Word
import Data.Ix
import Data.Text qualified as T
import Data.Text.Foreign.MiscYj
import Gpu.Vulkan.Exception.Middle.Internal
import Gpu.Vulkan.Exception.Enum
import Gpu.Vulkan.Device.Enum
import Gpu.Vulkan.AllocationCallbacks.Middle.Internal
qualified as AllocationCallbacks
import qualified Gpu.Vulkan.PhysicalDevice.Middle.Internal as PhysicalDevice
import qualified Gpu.Vulkan.PhysicalDevice.Struct as PhysicalDevice
import qualified Gpu.Vulkan.Device.Core as C
import {-# SOURCE #-} qualified Gpu.Vulkan.Queue.Middle.Internal as Queue
import qualified Gpu.Vulkan.QueueFamily.EnumManual as QueueFamily
import Gpu.Vulkan.Device.Middle.Types
enum "CreateFlagBits" ''Word32
{-# LINE 70 "src/Gpu/Vulkan/Device/Middle/Internal.hsc" #-}
[''Eq, ''Show, ''Storable, ''Bits] [("CreateFlagsZero", 0)]
type CreateFlags = CreateFlagBits
instance Default CreateFlags where def :: CreateFlagBits
def = CreateFlagBits
CreateFlagsZero
data CreateInfo mn qcis = CreateInfo {
forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> M mn
createInfoNext :: TMaybe.M mn,
forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> CreateFlagBits
createInfoFlags :: CreateFlags,
forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> PL QueueCreateInfo qcis
createInfoQueueCreateInfos :: HeteroParList.PL QueueCreateInfo qcis,
forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> [Text]
createInfoEnabledLayerNames :: [T.Text],
forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> [Text]
createInfoEnabledExtensionNames :: [T.Text],
forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> Maybe Features
createInfoEnabledFeatures :: Maybe PhysicalDevice.Features }
deriving instance (Show (TMaybe.M mn), Show (HeteroParList.PL QueueCreateInfo qcis)) =>
Show (CreateInfo mn qcis)
type family Map (f :: j -> k) xs where
Map _f '[] = '[]
Map f (x ': xs) = f x ': Map f xs
createInfoToCore :: (
WithPoked (TMaybe.M mn), HeteroParList.ToListWithCM' WithPoked TMaybe.M qcis) =>
CreateInfo mn qcis -> (Ptr C.CreateInfo -> IO a) -> IO ()
createInfoToCore :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]) a.
(WithPoked (M mn), ToListWithCM' WithPoked M qcis) =>
CreateInfo mn qcis -> (Ptr CreateInfo -> IO a) -> IO ()
createInfoToCore CreateInfo {
createInfoNext :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> M mn
createInfoNext = M mn
mnxt,
createInfoFlags :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> CreateFlagBits
createInfoFlags = CreateFlagBits Word32
flgs,
createInfoQueueCreateInfos :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> PL QueueCreateInfo qcis
createInfoQueueCreateInfos = PL QueueCreateInfo qcis
qcis,
createInfoEnabledLayerNames :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> [Text]
createInfoEnabledLayerNames = ([Text] -> [Text]
forall a. a -> a
id ([Text] -> [Text]) -> ([Text] -> Int) -> [Text] -> ([Text], Int)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) -> ([Text]
elns, Int
elnc),
createInfoEnabledExtensionNames :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> [Text]
createInfoEnabledExtensionNames = ([Text] -> [Text]
forall a. a -> a
id ([Text] -> [Text]) -> ([Text] -> Int) -> [Text] -> ([Text], Int)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) -> ([Text]
eens, Int
eenc),
createInfoEnabledFeatures :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]).
CreateInfo mn qcis -> Maybe Features
createInfoEnabledFeatures = Maybe Features
mef } Ptr CreateInfo -> IO a
f =
M mn -> (forall s. PtrS s (M mn) -> IO ()) -> IO ()
forall a b.
WithPoked a =>
a -> (forall s. PtrS s a -> IO b) -> IO b
forall b. M mn -> (forall s. PtrS s (M mn) -> IO b) -> IO b
withPoked' M mn
mnxt \PtrS s (M mn)
pnxt -> PtrS s (M mn) -> (Ptr (M mn) -> IO ()) -> IO ()
forall s a b. PtrS s a -> (Ptr a -> IO b) -> IO ()
withPtrS PtrS s (M mn)
pnxt \(Ptr (M mn) -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr -> Ptr ()
pnxt') ->
(Ptr CreateInfo -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr CreateInfo
pci ->
ContT () IO [QueueCreateInfo]
-> ([QueueCreateInfo] -> IO ()) -> IO ()
forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT (forall k k' (c :: k' -> Constraint) (t' :: k -> k') (ss :: [k])
(m :: * -> *) (t :: k -> *) a.
(ToListWithCM' c t' ss, Applicative m) =>
(forall (s :: k). c (t' s) => t s -> m a) -> PL t ss -> m [a]
HeteroParList.toListWithCM' @_ @_ @WithPoked @TMaybe.M (((QueueCreateInfo -> IO ()) -> IO ())
-> ContT () IO QueueCreateInfo
forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((QueueCreateInfo -> IO ()) -> IO ())
-> ContT () IO QueueCreateInfo)
-> (QueueCreateInfo s -> (QueueCreateInfo -> IO ()) -> IO ())
-> QueueCreateInfo s
-> ContT () IO QueueCreateInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueueCreateInfo s -> (QueueCreateInfo -> IO ()) -> IO ()
forall (mn :: Maybe (*)) a.
WithPoked (M mn) =>
QueueCreateInfo mn -> (QueueCreateInfo -> IO a) -> IO ()
queueCreateInfoToCore) PL QueueCreateInfo qcis
qcis) \[QueueCreateInfo]
cqcis ->
let qcic :: Int
qcic = [QueueCreateInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [QueueCreateInfo]
cqcis in
Int -> (Ptr QueueCreateInfo -> IO ()) -> IO ()
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
qcic \Ptr QueueCreateInfo
pcqcis ->
Ptr QueueCreateInfo -> [QueueCreateInfo] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr QueueCreateInfo
pcqcis [QueueCreateInfo]
cqcis IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
[Text] -> (Ptr CString -> IO ()) -> IO ()
forall a. [Text] -> (Ptr CString -> IO a) -> IO a
textListToCStringArray [Text]
elns \Ptr CString
pcelns ->
[Text] -> (Ptr CString -> IO ()) -> IO ()
forall a. [Text] -> (Ptr CString -> IO a) -> IO a
textListToCStringArray [Text]
eens \Ptr CString
pceens -> do
let mk :: PtrFeatures -> CreateInfo
mk PtrFeatures
pef = C.CreateInfo {
createInfoSType :: ()
C.createInfoSType = (),
createInfoPNext :: Ptr ()
C.createInfoPNext = Ptr ()
pnxt',
createInfoFlags :: Word32
C.createInfoFlags = Word32
flgs,
createInfoQueueCreateInfoCount :: Word32
C.createInfoQueueCreateInfoCount = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
qcic,
createInfoPQueueCreateInfos :: Ptr QueueCreateInfo
C.createInfoPQueueCreateInfos = Ptr QueueCreateInfo
pcqcis,
createInfoEnabledLayerCount :: Word32
C.createInfoEnabledLayerCount = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
elnc,
createInfoPpEnabledLayerNames :: Ptr CString
C.createInfoPpEnabledLayerNames = Ptr CString
pcelns,
createInfoEnabledExtensionCount :: Word32
C.createInfoEnabledExtensionCount = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
eenc,
createInfoPpEnabledExtensionNames :: Ptr CString
C.createInfoPpEnabledExtensionNames = Ptr CString
pceens,
createInfoPEnabledFeatures :: PtrFeatures
C.createInfoPEnabledFeatures = PtrFeatures
pef }
case Maybe Features
mef of
Maybe Features
Nothing -> Ptr CreateInfo -> CreateInfo -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CreateInfo
pci (PtrFeatures -> CreateInfo
mk PtrFeatures
forall a. Ptr a
NullPtr)
Just Features
ef -> (PtrFeatures -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \PtrFeatures
p -> do
PtrFeatures -> Features -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke PtrFeatures
p (Features -> IO ()) -> Features -> IO ()
forall a b. (a -> b) -> a -> b
$ Features -> Features
PhysicalDevice.featuresToCore Features
ef
Ptr CreateInfo -> CreateInfo -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CreateInfo
pci (PtrFeatures -> CreateInfo
mk PtrFeatures
p)
() () -> IO a -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Ptr CreateInfo -> IO a
f Ptr CreateInfo
pci
create :: (WithPoked (TMaybe.M mn), HeteroParList.ToListWithCM' WithPoked TMaybe.M qcis) =>
PhysicalDevice.P -> CreateInfo mn qcis -> TPMaybe.M AllocationCallbacks.A mc ->
IO D
create :: forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]) (mc :: Maybe (*)).
(WithPoked (M mn), ToListWithCM' WithPoked M qcis) =>
P -> CreateInfo mn qcis -> M A mc -> IO D
create (PhysicalDevice.P P
phdvc) CreateInfo mn qcis
ci M A mc
mac = D -> D
D (D -> D) -> IO D -> IO D
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr D -> IO D) -> IO D
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr D
pdvc -> do
CreateInfo mn qcis -> (Ptr CreateInfo -> IO ()) -> IO ()
forall (mn :: Maybe (*)) (qcis :: [Maybe (*)]) a.
(WithPoked (M mn), ToListWithCM' WithPoked M qcis) =>
CreateInfo mn qcis -> (Ptr CreateInfo -> IO a) -> IO ()
createInfoToCore CreateInfo mn qcis
ci \Ptr CreateInfo
pcci ->
M A mc -> (Ptr A -> IO ()) -> IO ()
forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO ()
AllocationCallbacks.mToCore M A mc
mac \Ptr A
pac -> do
Int32
r <- P -> Ptr CreateInfo -> Ptr A -> Ptr D -> IO Int32
C.create P
phdvc Ptr CreateInfo
pcci Ptr A
pac Ptr D
pdvc
Result -> IO ()
throwUnlessSuccess (Result -> IO ()) -> Result -> IO ()
forall a b. (a -> b) -> a -> b
$ Int32 -> Result
Result Int32
r
Ptr D -> IO D
forall a. Storable a => Ptr a -> IO a
peek Ptr D
pdvc
destroy :: D -> TPMaybe.M AllocationCallbacks.A md -> IO ()
destroy :: forall (md :: Maybe (*)). D -> M A md -> IO ()
destroy (D D
cdvc) M A md
mac = M A md -> (Ptr A -> IO ()) -> IO ()
forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO ()
AllocationCallbacks.mToCore M A md
mac ((Ptr A -> IO ()) -> IO ()) -> (Ptr A -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ D -> Ptr A -> IO ()
C.destroy D
cdvc
getQueue :: D -> Word32 -> Word32 -> IO Queue.Q
getQueue :: D -> Word32 -> Word32 -> IO Q
getQueue (D D
cdvc) Word32
qfi Word32
qi = Q -> Q
Queue.Q (Q -> Q) -> IO Q -> IO Q
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr Q -> IO Q) -> IO Q
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr Q
pQueue -> do
D -> Word32 -> Word32 -> Ptr Q -> IO ()
C.getQueue D
cdvc Word32
qfi Word32
qi Ptr Q
pQueue
Ptr Q -> IO Q
forall a. Storable a => Ptr a -> IO a
peek Ptr Q
pQueue
waitIdle :: D -> IO ()
waitIdle :: D -> IO ()
waitIdle (D D
d) = Result -> IO ()
throwUnlessSuccess (Result -> IO ()) -> (Int32 -> Result) -> Int32 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Result
Result (Int32 -> IO ()) -> IO Int32 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< D -> IO Int32
C.waitIdle D
d
data QueueCreateInfo mn = QueueCreateInfo {
forall (mn :: Maybe (*)). QueueCreateInfo mn -> M mn
queueCreateInfoNext :: TMaybe.M mn,
forall (mn :: Maybe (*)). QueueCreateInfo mn -> QueueCreateFlags
queueCreateInfoFlags :: QueueCreateFlags,
forall (mn :: Maybe (*)). QueueCreateInfo mn -> Index
queueCreateInfoQueueFamilyIndex :: QueueFamily.Index,
forall (mn :: Maybe (*)). QueueCreateInfo mn -> [Float]
queueCreateInfoQueuePriorities :: [Float] }
deriving instance Show (TMaybe.M mn) => Show (QueueCreateInfo mn)
queueCreateInfoToCore :: WithPoked (TMaybe.M mn) =>
QueueCreateInfo mn -> (C.QueueCreateInfo -> IO a) -> IO ()
queueCreateInfoToCore :: forall (mn :: Maybe (*)) a.
WithPoked (M mn) =>
QueueCreateInfo mn -> (QueueCreateInfo -> IO a) -> IO ()
queueCreateInfoToCore QueueCreateInfo {
queueCreateInfoNext :: forall (mn :: Maybe (*)). QueueCreateInfo mn -> M mn
queueCreateInfoNext = M mn
mnxt,
queueCreateInfoFlags :: forall (mn :: Maybe (*)). QueueCreateInfo mn -> QueueCreateFlags
queueCreateInfoFlags = QueueCreateFlagBits Word32
flgs,
queueCreateInfoQueueFamilyIndex :: forall (mn :: Maybe (*)). QueueCreateInfo mn -> Index
queueCreateInfoQueueFamilyIndex = QueueFamily.Index Word32
qfi,
queueCreateInfoQueuePriorities :: forall (mn :: Maybe (*)). QueueCreateInfo mn -> [Float]
queueCreateInfoQueuePriorities = [Float]
qps
} QueueCreateInfo -> IO a
f = Int -> (Ptr Float -> IO ()) -> IO ()
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray ([Float] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Float]
qps) \Ptr Float
pqps -> do
Ptr Float -> [Float] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr Float
pqps [Float]
qps
M mn -> (forall s. PtrS s (M mn) -> IO ()) -> IO ()
forall a b.
WithPoked a =>
a -> (forall s. PtrS s a -> IO b) -> IO b
forall b. M mn -> (forall s. PtrS s (M mn) -> IO b) -> IO b
withPoked' M mn
mnxt \PtrS s (M mn)
pnxt -> PtrS s (M mn) -> (Ptr (M mn) -> IO ()) -> IO ()
forall s a b. PtrS s a -> (Ptr a -> IO b) -> IO ()
withPtrS PtrS s (M mn)
pnxt \(Ptr (M mn) -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr -> Ptr ()
pnxt') ->
() () -> IO a -> IO ()
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ QueueCreateInfo -> IO a
f C.QueueCreateInfo {
queueCreateInfoSType :: ()
C.queueCreateInfoSType = (),
queueCreateInfoPNext :: Ptr ()
C.queueCreateInfoPNext = Ptr ()
pnxt',
queueCreateInfoFlags :: Word32
C.queueCreateInfoFlags = Word32
flgs,
queueCreateInfoQueueFamilyIndex :: Word32
C.queueCreateInfoQueueFamilyIndex = Word32
qfi,
queueCreateInfoQueueCount :: Word32
C.queueCreateInfoQueueCount = [Float] -> Word32
forall i a. Num i => [a] -> i
genericLength [Float]
qps,
queueCreateInfoPQueuePriorities :: Ptr Float
C.queueCreateInfoPQueuePriorities = Ptr Float
pqps }