{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Gpu.Vulkan.Fence.Internal (

	-- * CREATE

	create, F(..), M.CreateInfo(..),

	-- ** Group

	group, Group, create', unsafeDestroy, lookup,

	-- * WAIT FOR FENCES AND RESET FENCES

	waitForFs, resetFs

	) where

import Prelude hiding (lookup)
import Foreign.Storable.PeekPoke
import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Control.Exception
import Data.TypeLevel.Maybe qualified as TMaybe
import Data.TypeLevel.ParMaybe qualified as TPMaybe
import Data.TypeLevel.Tuple.Uncurry
import Data.HeteroParList qualified as HeteroParList
import Data.Map qualified as Map
import Data.Word
import Data.Time

import Gpu.Vulkan.Fence.Type

import qualified Gpu.Vulkan.Device.Type as Device
import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks
import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks
import qualified Gpu.Vulkan.Fence.Middle as M

create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) =>
	Device.D sd -> M.CreateInfo mn ->
	TPMaybe.M (U2 AllocationCallbacks.A) mac ->
	(forall s . F s -> IO a) -> IO a
create :: forall (mn :: Maybe (*)) (mac :: Maybe (*, *)) sd a.
(WithPoked (M mn), ToMiddle mac) =>
D sd
-> CreateInfo mn -> M (U2 A) mac -> (forall s. F s -> IO a) -> IO a
create (Device.D D
dvc) CreateInfo mn
ci (M (U2 A) mac -> M A (Snd mac)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd mac)
mac) forall s. F s -> IO a
f =
	IO F -> (F -> IO ()) -> (F -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (D -> CreateInfo mn -> M A (Snd mac) -> IO F
forall (mn :: Maybe (*)) (mc :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> IO F
M.create D
dvc CreateInfo mn
ci M A (Snd mac)
mac) (\F
fnc -> D -> F -> M A (Snd mac) -> IO ()
forall (md :: Maybe (*)). D -> F -> M A md -> IO ()
M.destroy D
dvc F
fnc M A (Snd mac)
mac) (F Any -> IO a
forall s. F s -> IO a
f (F Any -> IO a) -> (F -> F Any) -> F -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F -> F Any
forall sf. F -> F sf
F)

waitForFs :: Device.D sd -> HeteroParList.PL F sfs -> Bool -> Maybe DiffTime -> IO ()
waitForFs :: forall sd (sfs :: [*]).
D sd -> PL F sfs -> Bool -> Maybe DiffTime -> IO ()
waitForFs (Device.D D
dvc) PL F sfs
fs Bool
wa (Word64 -> (DiffTime -> Word64) -> Maybe DiffTime -> Word64
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word64
forall a. Bounded a => a
maxBound DiffTime -> Word64
diffTimeToNanoseconds -> Word64
to) =
	D -> [F] -> Bool -> Word64 -> IO ()
M.waitForFs D
dvc ((forall s. F s -> F) -> PL F sfs -> [F]
forall k (t :: k -> *) a (ss :: [k]).
(forall (s :: k). t s -> a) -> PL t ss -> [a]
HeteroParList.toList (\(F F
f) -> F
f) PL F sfs
fs) Bool
wa Word64
to

resetFs :: Device.D sd -> HeteroParList.PL F sfs -> IO ()
resetFs :: forall sd (sfs :: [*]). D sd -> PL F sfs -> IO ()
resetFs (Device.D D
dvc) = D -> [F] -> IO ()
M.resetFs D
dvc ([F] -> IO ()) -> (PL F sfs -> [F]) -> PL F sfs -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s. F s -> F) -> PL F sfs -> [F]
forall k (t :: k -> *) a (ss :: [k]).
(forall (s :: k). t s -> a) -> PL t ss -> [a]
HeteroParList.toList \(F F
f) -> F
f

diffTimeToNanoseconds :: DiffTime -> Word64
diffTimeToNanoseconds :: DiffTime -> Word64
diffTimeToNanoseconds = Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Word64) -> (DiffTime -> Integer) -> DiffTime -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
1000) (Integer -> Integer)
-> (DiffTime -> Integer) -> DiffTime -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Integer
diffTimeToPicoseconds

data Group sd ma sf k = Group (Device.D sd)
	(TPMaybe.M (U2 AllocationCallbacks.A) ma) TSem (TVar (Map.Map k (F sf)))

group :: AllocationCallbacks.ToMiddle ma =>
	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->
	(forall sf . Group sd ma sf k -> IO a) -> IO a
group :: forall (ma :: Maybe (*, *)) sd k a.
ToMiddle ma =>
D sd
-> M (U2 A) ma -> (forall sf. Group sd ma sf k -> IO a) -> IO a
group dvc :: D sd
dvc@(Device.D D
mdvc) mac :: M (U2 A) ma
mac@(M (U2 A) ma -> M A (Snd ma)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd ma)
mmac) forall sf. Group sd ma sf k -> IO a
f = do
	(TSem
sem, TVar (Map k (F Any))
m) <- STM (TSem, TVar (Map k (F Any))) -> IO (TSem, TVar (Map k (F Any)))
forall a. STM a -> IO a
atomically (STM (TSem, TVar (Map k (F Any)))
 -> IO (TSem, TVar (Map k (F Any))))
-> STM (TSem, TVar (Map k (F Any)))
-> IO (TSem, TVar (Map k (F Any)))
forall a b. (a -> b) -> a -> b
$ (,) (TSem -> TVar (Map k (F Any)) -> (TSem, TVar (Map k (F Any))))
-> STM TSem
-> STM (TVar (Map k (F Any)) -> (TSem, TVar (Map k (F Any))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> STM TSem
newTSem Integer
1 STM (TVar (Map k (F Any)) -> (TSem, TVar (Map k (F Any))))
-> STM (TVar (Map k (F Any))) -> STM (TSem, TVar (Map k (F Any)))
forall a b. STM (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map k (F Any) -> STM (TVar (Map k (F Any)))
forall a. a -> STM (TVar a)
newTVar Map k (F Any)
forall k a. Map k a
Map.empty
	a
rtn <- Group sd ma Any k -> IO a
forall sf. Group sd ma sf k -> IO a
f (Group sd ma Any k -> IO a) -> Group sd ma Any k -> IO a
forall a b. (a -> b) -> a -> b
$ D sd
-> M (U2 A) ma -> TSem -> TVar (Map k (F Any)) -> Group sd ma Any k
forall sd (ma :: Maybe (*, *)) sf k.
D sd
-> M (U2 A) ma -> TSem -> TVar (Map k (F sf)) -> Group sd ma sf k
Group D sd
dvc M (U2 A) ma
mac TSem
sem TVar (Map k (F Any))
m
	((\(F F
s) -> D -> F -> M A (Snd ma) -> IO ()
forall (md :: Maybe (*)). D -> F -> M A md -> IO ()
M.destroy D
mdvc F
s M A (Snd ma)
mmac) (F Any -> IO ()) -> Map k (F Any) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_`) (Map k (F Any) -> IO ()) -> IO (Map k (F Any)) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM (Map k (F Any)) -> IO (Map k (F Any))
forall a. STM a -> IO a
atomically (TVar (Map k (F Any)) -> STM (Map k (F Any))
forall a. TVar a -> STM a
readTVar TVar (Map k (F Any))
m)
	a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
rtn

create' :: (
	Ord k, WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle ma) =>
	Group sd ma sf k -> k -> M.CreateInfo mn -> IO (Either String (F sf))
create' :: forall k (mn :: Maybe (*)) (ma :: Maybe (*, *)) sd sf.
(Ord k, WithPoked (M mn), ToMiddle ma) =>
Group sd ma sf k -> k -> CreateInfo mn -> IO (Either String (F sf))
create' (Group (Device.D D
mdvc)
	(M (U2 A) ma -> M A (Snd ma)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd ma)
mmac) TSem
sem TVar (Map k (F sf))
sf) k
k CreateInfo mn
ci = do
	Bool
ok <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically do
		Maybe (F sf)
mx <- k -> Map k (F sf) -> Maybe (F sf)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (F sf) -> Maybe (F sf))
-> STM (Map k (F sf)) -> STM (Maybe (F sf))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (F sf)) -> STM (Map k (F sf))
forall a. TVar a -> STM a
readTVar TVar (Map k (F sf))
sf
		case Maybe (F sf)
mx of
			Maybe (F sf)
Nothing -> TSem -> STM ()
waitTSem TSem
sem STM () -> STM Bool -> STM Bool
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
			Just F sf
_ -> Bool -> STM Bool
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
	if Bool
ok
	then do	F
f <- D -> CreateInfo mn -> M A (Snd ma) -> IO F
forall (mn :: Maybe (*)) (mc :: Maybe (*)).
WithPoked (M mn) =>
D -> CreateInfo mn -> M A mc -> IO F
M.create D
mdvc CreateInfo mn
ci M A (Snd ma)
mmac
		let	f' :: F sf
f' = F -> F sf
forall sf. F -> F sf
F F
f
		STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map k (F sf)) -> (Map k (F sf) -> Map k (F sf)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map k (F sf))
sf (k -> F sf -> Map k (F sf) -> Map k (F sf)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k F sf
f') STM () -> STM () -> STM ()
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TSem -> STM ()
signalTSem TSem
sem
		Either String (F sf) -> IO (Either String (F sf))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (F sf) -> IO (Either String (F sf)))
-> Either String (F sf) -> IO (Either String (F sf))
forall a b. (a -> b) -> a -> b
$ F sf -> Either String (F sf)
forall a b. b -> Either a b
Right F sf
f'
	else Either String (F sf) -> IO (Either String (F sf))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (F sf) -> IO (Either String (F sf)))
-> (String -> Either String (F sf))
-> String
-> IO (Either String (F sf))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (F sf)
forall a b. a -> Either a b
Left (String -> IO (Either String (F sf)))
-> String -> IO (Either String (F sf))
forall a b. (a -> b) -> a -> b
$
		String
"Gpu.Vulkan.Fence.Internal.create': The key already exist"

unsafeDestroy :: (
	Ord k, AllocationCallbacks.ToMiddle ma) =>
	Group sd ma sf k -> k -> IO (Either String ())
unsafeDestroy :: forall k (ma :: Maybe (*, *)) sd sf.
(Ord k, ToMiddle ma) =>
Group sd ma sf k -> k -> IO (Either String ())
unsafeDestroy (Group (Device.D D
mdvc)
	(M (U2 A) ma -> M A (Snd ma)
forall (msa :: Maybe (*, *)).
ToMiddle msa =>
M (U2 A) msa -> M A (Snd msa)
AllocationCallbacks.toMiddle -> M A (Snd ma)
ma) TSem
sem TVar (Map k (F sf))
fs) k
k = do
	Maybe (F sf)
mf <- STM (Maybe (F sf)) -> IO (Maybe (F sf))
forall a. STM a -> IO a
atomically do
		Maybe (F sf)
mx <- k -> Map k (F sf) -> Maybe (F sf)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (F sf) -> Maybe (F sf))
-> STM (Map k (F sf)) -> STM (Maybe (F sf))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (F sf)) -> STM (Map k (F sf))
forall a. TVar a -> STM a
readTVar TVar (Map k (F sf))
fs
		case Maybe (F sf)
mx of
			Maybe (F sf)
Nothing -> Maybe (F sf) -> STM (Maybe (F sf))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (F sf)
forall a. Maybe a
Nothing
			Just F sf
_ -> TSem -> STM ()
waitTSem TSem
sem STM () -> STM (Maybe (F sf)) -> STM (Maybe (F sf))
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (F sf) -> STM (Maybe (F sf))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (F sf)
mx
	case Maybe (F sf)
mf of
		Maybe (F sf)
Nothing -> Either String () -> IO (Either String ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String () -> IO (Either String ()))
-> Either String () -> IO (Either String ())
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left
			String
"Gpu.Vulkan.Fence.unsafeDestroy: No such key"
		Just (F F
f) -> do
			D -> F -> M A (Snd ma) -> IO ()
forall (md :: Maybe (*)). D -> F -> M A md -> IO ()
M.destroy D
mdvc F
f M A (Snd ma)
ma
			STM (Either String ()) -> IO (Either String ())
forall a. STM a -> IO a
atomically do
				TVar (Map k (F sf)) -> (Map k (F sf) -> Map k (F sf)) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map k (F sf))
fs ((Map k (F sf) -> Map k (F sf)) -> STM ())
-> (Map k (F sf) -> Map k (F sf)) -> STM ()
forall a b. (a -> b) -> a -> b
$ k -> Map k (F sf) -> Map k (F sf)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
k
				TSem -> STM ()
signalTSem TSem
sem
				Either String () -> STM (Either String ())
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String () -> STM (Either String ()))
-> Either String () -> STM (Either String ())
forall a b. (a -> b) -> a -> b
$ () -> Either String ()
forall a b. b -> Either a b
Right ()

lookup :: Ord k => Group sd ma sf k -> k -> IO (Maybe (F sf))
lookup :: forall k sd (ma :: Maybe (*, *)) sf.
Ord k =>
Group sd ma sf k -> k -> IO (Maybe (F sf))
lookup (Group D sd
_ M (U2 A) ma
_ TSem
_sem TVar (Map k (F sf))
fs) k
k = STM (Maybe (F sf)) -> IO (Maybe (F sf))
forall a. STM a -> IO a
atomically (STM (Maybe (F sf)) -> IO (Maybe (F sf)))
-> STM (Maybe (F sf)) -> IO (Maybe (F sf))
forall a b. (a -> b) -> a -> b
$ k -> Map k (F sf) -> Maybe (F sf)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k (Map k (F sf) -> Maybe (F sf))
-> STM (Map k (F sf)) -> STM (Maybe (F sf))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map k (F sf)) -> STM (Map k (F sf))
forall a. TVar a -> STM a
readTVar TVar (Map k (F sf))
fs