--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.OpenGL.GL.SyncObjects
-- Copyright   :  (c) Sven Panne 2019
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <[email protected]>
-- Stability   :  stable
-- Portability :  portable
--
-- This module corresponds to section 4.1 (Sync Objects and Fences) of the
-- OpenGL 4.4 specs.
--
--------------------------------------------------------------------------------

module Graphics.Rendering.OpenGL.GL.SyncObjects (
   -- * Sync Objects and Fences
   SyncObject, syncGpuCommandsComplete,

   -- * Waiting for Sync Objects
   WaitTimeout, WaitFlag(..), WaitResult(..), clientWaitSync,
   waitSync, maxServerWaitTimeout,

   -- * Sync Object Queries
   SyncStatus(..), syncStatus
) where

import Control.Monad.IO.Class
import Data.ObjectName
import Data.StateVar
import Foreign.Marshal.Utils ( with )
import Foreign.Ptr ( nullPtr )
import Graphics.Rendering.OpenGL.GL.DebugOutput
import Graphics.Rendering.OpenGL.GL.GLboolean
import Graphics.Rendering.OpenGL.GL.PeekPoke
import Graphics.Rendering.OpenGL.GL.QueryUtils
import Graphics.GL

--------------------------------------------------------------------------------

newtype SyncObject = SyncObject { SyncObject -> GLsync
syncID :: GLsync }
   deriving ( SyncObject -> SyncObject -> Bool
(SyncObject -> SyncObject -> Bool)
-> (SyncObject -> SyncObject -> Bool) -> Eq SyncObject
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SyncObject -> SyncObject -> Bool
== :: SyncObject -> SyncObject -> Bool
$c/= :: SyncObject -> SyncObject -> Bool
/= :: SyncObject -> SyncObject -> Bool
Eq, Eq SyncObject
Eq SyncObject =>
(SyncObject -> SyncObject -> Ordering)
-> (SyncObject -> SyncObject -> Bool)
-> (SyncObject -> SyncObject -> Bool)
-> (SyncObject -> SyncObject -> Bool)
-> (SyncObject -> SyncObject -> Bool)
-> (SyncObject -> SyncObject -> SyncObject)
-> (SyncObject -> SyncObject -> SyncObject)
-> Ord SyncObject
SyncObject -> SyncObject -> Bool
SyncObject -> SyncObject -> Ordering
SyncObject -> SyncObject -> SyncObject
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SyncObject -> SyncObject -> Ordering
compare :: SyncObject -> SyncObject -> Ordering
$c< :: SyncObject -> SyncObject -> Bool
< :: SyncObject -> SyncObject -> Bool
$c<= :: SyncObject -> SyncObject -> Bool
<= :: SyncObject -> SyncObject -> Bool
$c> :: SyncObject -> SyncObject -> Bool
> :: SyncObject -> SyncObject -> Bool
$c>= :: SyncObject -> SyncObject -> Bool
>= :: SyncObject -> SyncObject -> Bool
$cmax :: SyncObject -> SyncObject -> SyncObject
max :: SyncObject -> SyncObject -> SyncObject
$cmin :: SyncObject -> SyncObject -> SyncObject
min :: SyncObject -> SyncObject -> SyncObject
Ord, Int -> SyncObject -> ShowS
[SyncObject] -> ShowS
SyncObject -> String
(Int -> SyncObject -> ShowS)
-> (SyncObject -> String)
-> ([SyncObject] -> ShowS)
-> Show SyncObject
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SyncObject -> ShowS
showsPrec :: Int -> SyncObject -> ShowS
$cshow :: SyncObject -> String
show :: SyncObject -> String
$cshowList :: [SyncObject] -> ShowS
showList :: [SyncObject] -> ShowS
Show )

instance ObjectName SyncObject where
   isObjectName :: forall (m :: * -> *). MonadIO m => SyncObject -> m Bool
isObjectName = IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool)
-> (SyncObject -> IO Bool) -> SyncObject -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GLboolean -> Bool) -> IO GLboolean -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GLboolean -> Bool
forall a. (Eq a, Num a) => a -> Bool
unmarshalGLboolean (IO GLboolean -> IO Bool)
-> (SyncObject -> IO GLboolean) -> SyncObject -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLsync -> IO GLboolean
forall (m :: * -> *). MonadIO m => GLsync -> m GLboolean
glIsSync (GLsync -> IO GLboolean)
-> (SyncObject -> GLsync) -> SyncObject -> IO GLboolean
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SyncObject -> GLsync
syncID
   deleteObjectName :: forall (m :: * -> *). MonadIO m => SyncObject -> m ()
deleteObjectName = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (SyncObject -> IO ()) -> SyncObject -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLsync -> IO ()
forall (m :: * -> *). MonadIO m => GLsync -> m ()
glDeleteSync (GLsync -> IO ()) -> (SyncObject -> GLsync) -> SyncObject -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SyncObject -> GLsync
syncID

instance CanBeLabeled SyncObject where
   objectLabel :: SyncObject -> StateVar (Maybe String)
objectLabel = GLsync -> StateVar (Maybe String)
objectPtrLabel (GLsync -> StateVar (Maybe String))
-> (SyncObject -> GLsync) -> SyncObject -> StateVar (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SyncObject -> GLsync
syncID

syncGpuCommandsComplete :: IO SyncObject
syncGpuCommandsComplete :: IO SyncObject
syncGpuCommandsComplete =
   (GLsync -> SyncObject) -> IO GLsync -> IO SyncObject
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GLsync -> SyncObject
SyncObject (IO GLsync -> IO SyncObject) -> IO GLsync -> IO SyncObject
forall a b. (a -> b) -> a -> b
$ GLenum -> GLenum -> IO GLsync
forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m GLsync
glFenceSync GLenum
GL_SYNC_GPU_COMMANDS_COMPLETE GLenum
0

--------------------------------------------------------------------------------

type WaitTimeout = GLuint64

--------------------------------------------------------------------------------

data WaitFlag = SyncFlushCommands
   deriving ( WaitFlag -> WaitFlag -> Bool
(WaitFlag -> WaitFlag -> Bool)
-> (WaitFlag -> WaitFlag -> Bool) -> Eq WaitFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WaitFlag -> WaitFlag -> Bool
== :: WaitFlag -> WaitFlag -> Bool
$c/= :: WaitFlag -> WaitFlag -> Bool
/= :: WaitFlag -> WaitFlag -> Bool
Eq, Eq WaitFlag
Eq WaitFlag =>
(WaitFlag -> WaitFlag -> Ordering)
-> (WaitFlag -> WaitFlag -> Bool)
-> (WaitFlag -> WaitFlag -> Bool)
-> (WaitFlag -> WaitFlag -> Bool)
-> (WaitFlag -> WaitFlag -> Bool)
-> (WaitFlag -> WaitFlag -> WaitFlag)
-> (WaitFlag -> WaitFlag -> WaitFlag)
-> Ord WaitFlag
WaitFlag -> WaitFlag -> Bool
WaitFlag -> WaitFlag -> Ordering
WaitFlag -> WaitFlag -> WaitFlag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: WaitFlag -> WaitFlag -> Ordering
compare :: WaitFlag -> WaitFlag -> Ordering
$c< :: WaitFlag -> WaitFlag -> Bool
< :: WaitFlag -> WaitFlag -> Bool
$c<= :: WaitFlag -> WaitFlag -> Bool
<= :: WaitFlag -> WaitFlag -> Bool
$c> :: WaitFlag -> WaitFlag -> Bool
> :: WaitFlag -> WaitFlag -> Bool
$c>= :: WaitFlag -> WaitFlag -> Bool
>= :: WaitFlag -> WaitFlag -> Bool
$cmax :: WaitFlag -> WaitFlag -> WaitFlag
max :: WaitFlag -> WaitFlag -> WaitFlag
$cmin :: WaitFlag -> WaitFlag -> WaitFlag
min :: WaitFlag -> WaitFlag -> WaitFlag
Ord, Int -> WaitFlag -> ShowS
[WaitFlag] -> ShowS
WaitFlag -> String
(Int -> WaitFlag -> ShowS)
-> (WaitFlag -> String) -> ([WaitFlag] -> ShowS) -> Show WaitFlag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WaitFlag -> ShowS
showsPrec :: Int -> WaitFlag -> ShowS
$cshow :: WaitFlag -> String
show :: WaitFlag -> String
$cshowList :: [WaitFlag] -> ShowS
showList :: [WaitFlag] -> ShowS
Show )

marshalWaitFlag :: WaitFlag -> GLbitfield
marshalWaitFlag :: WaitFlag -> GLenum
marshalWaitFlag WaitFlag
x = case WaitFlag
x of
   WaitFlag
SyncFlushCommands -> GLenum
GL_SYNC_FLUSH_COMMANDS_BIT

--------------------------------------------------------------------------------

data WaitResult =
     AlreadySignaled
   | TimeoutExpired
   | ConditionSatisfied
   | WaitFailed
   deriving ( WaitResult -> WaitResult -> Bool
(WaitResult -> WaitResult -> Bool)
-> (WaitResult -> WaitResult -> Bool) -> Eq WaitResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WaitResult -> WaitResult -> Bool
== :: WaitResult -> WaitResult -> Bool
$c/= :: WaitResult -> WaitResult -> Bool
/= :: WaitResult -> WaitResult -> Bool
Eq, Eq WaitResult
Eq WaitResult =>
(WaitResult -> WaitResult -> Ordering)
-> (WaitResult -> WaitResult -> Bool)
-> (WaitResult -> WaitResult -> Bool)
-> (WaitResult -> WaitResult -> Bool)
-> (WaitResult -> WaitResult -> Bool)
-> (WaitResult -> WaitResult -> WaitResult)
-> (WaitResult -> WaitResult -> WaitResult)
-> Ord WaitResult
WaitResult -> WaitResult -> Bool
WaitResult -> WaitResult -> Ordering
WaitResult -> WaitResult -> WaitResult
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: WaitResult -> WaitResult -> Ordering
compare :: WaitResult -> WaitResult -> Ordering
$c< :: WaitResult -> WaitResult -> Bool
< :: WaitResult -> WaitResult -> Bool
$c<= :: WaitResult -> WaitResult -> Bool
<= :: WaitResult -> WaitResult -> Bool
$c> :: WaitResult -> WaitResult -> Bool
> :: WaitResult -> WaitResult -> Bool
$c>= :: WaitResult -> WaitResult -> Bool
>= :: WaitResult -> WaitResult -> Bool
$cmax :: WaitResult -> WaitResult -> WaitResult
max :: WaitResult -> WaitResult -> WaitResult
$cmin :: WaitResult -> WaitResult -> WaitResult
min :: WaitResult -> WaitResult -> WaitResult
Ord, Int -> WaitResult -> ShowS
[WaitResult] -> ShowS
WaitResult -> String
(Int -> WaitResult -> ShowS)
-> (WaitResult -> String)
-> ([WaitResult] -> ShowS)
-> Show WaitResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WaitResult -> ShowS
showsPrec :: Int -> WaitResult -> ShowS
$cshow :: WaitResult -> String
show :: WaitResult -> String
$cshowList :: [WaitResult] -> ShowS
showList :: [WaitResult] -> ShowS
Show )

unmarshalWaitResult :: GLenum -> WaitResult
unmarshalWaitResult :: GLenum -> WaitResult
unmarshalWaitResult GLenum
x
   | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_ALREADY_SIGNALED = WaitResult
AlreadySignaled
   | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_TIMEOUT_EXPIRED = WaitResult
TimeoutExpired
   | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_CONDITION_SATISFIED = WaitResult
ConditionSatisfied
   | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_WAIT_FAILED = WaitResult
WaitFailed
   | Bool
otherwise = String -> WaitResult
forall a. HasCallStack => String -> a
error (String
"unmarshalWaitResult: illegal value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GLenum -> String
forall a. Show a => a -> String
show GLenum
x)

--------------------------------------------------------------------------------

clientWaitSync :: SyncObject -> [WaitFlag] -> WaitTimeout -> IO WaitResult
clientWaitSync :: SyncObject -> [WaitFlag] -> WaitTimeout -> IO WaitResult
clientWaitSync SyncObject
syncObject [WaitFlag]
flags =
   (GLenum -> WaitResult) -> IO GLenum -> IO WaitResult
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GLenum -> WaitResult
unmarshalWaitResult (IO GLenum -> IO WaitResult)
-> (WaitTimeout -> IO GLenum) -> WaitTimeout -> IO WaitResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      GLsync -> GLenum -> WaitTimeout -> IO GLenum
forall (m :: * -> *).
MonadIO m =>
GLsync -> GLenum -> WaitTimeout -> m GLenum
glClientWaitSync (SyncObject -> GLsync
syncID SyncObject
syncObject) ([GLenum] -> GLenum
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((WaitFlag -> GLenum) -> [WaitFlag] -> [GLenum]
forall a b. (a -> b) -> [a] -> [b]
map WaitFlag -> GLenum
marshalWaitFlag [WaitFlag]
flags))

waitSync :: SyncObject -> IO ()
waitSync :: SyncObject -> IO ()
waitSync SyncObject
syncObject =
   GLsync -> GLenum -> WaitTimeout -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLsync -> GLenum -> WaitTimeout -> m ()
glWaitSync (SyncObject -> GLsync
syncID SyncObject
syncObject) GLenum
0 (WaitTimeout -> WaitTimeout
forall a b. (Integral a, Num b) => a -> b
fromIntegral WaitTimeout
GL_TIMEOUT_IGNORED)

maxServerWaitTimeout :: GettableStateVar WaitTimeout
maxServerWaitTimeout :: GettableStateVar WaitTimeout
maxServerWaitTimeout =
   GettableStateVar WaitTimeout -> GettableStateVar WaitTimeout
forall a. IO a -> IO a
makeGettableStateVar ((GLint64 -> WaitTimeout) -> PName1I -> GettableStateVar WaitTimeout
forall p a. GetPName1I p => (GLint64 -> a) -> p -> IO a
forall a. (GLint64 -> a) -> PName1I -> IO a
getInteger64 GLint64 -> WaitTimeout
forall a b. (Integral a, Num b) => a -> b
fromIntegral PName1I
GetMaxServerWaitTimeout)

--------------------------------------------------------------------------------

data SyncStatus =
     Unsignaled
   | Signaled
   deriving ( SyncStatus -> SyncStatus -> Bool
(SyncStatus -> SyncStatus -> Bool)
-> (SyncStatus -> SyncStatus -> Bool) -> Eq SyncStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SyncStatus -> SyncStatus -> Bool
== :: SyncStatus -> SyncStatus -> Bool
$c/= :: SyncStatus -> SyncStatus -> Bool
/= :: SyncStatus -> SyncStatus -> Bool
Eq, Eq SyncStatus
Eq SyncStatus =>
(SyncStatus -> SyncStatus -> Ordering)
-> (SyncStatus -> SyncStatus -> Bool)
-> (SyncStatus -> SyncStatus -> Bool)
-> (SyncStatus -> SyncStatus -> Bool)
-> (SyncStatus -> SyncStatus -> Bool)
-> (SyncStatus -> SyncStatus -> SyncStatus)
-> (SyncStatus -> SyncStatus -> SyncStatus)
-> Ord SyncStatus
SyncStatus -> SyncStatus -> Bool
SyncStatus -> SyncStatus -> Ordering
SyncStatus -> SyncStatus -> SyncStatus
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SyncStatus -> SyncStatus -> Ordering
compare :: SyncStatus -> SyncStatus -> Ordering
$c< :: SyncStatus -> SyncStatus -> Bool
< :: SyncStatus -> SyncStatus -> Bool
$c<= :: SyncStatus -> SyncStatus -> Bool
<= :: SyncStatus -> SyncStatus -> Bool
$c> :: SyncStatus -> SyncStatus -> Bool
> :: SyncStatus -> SyncStatus -> Bool
$c>= :: SyncStatus -> SyncStatus -> Bool
>= :: SyncStatus -> SyncStatus -> Bool
$cmax :: SyncStatus -> SyncStatus -> SyncStatus
max :: SyncStatus -> SyncStatus -> SyncStatus
$cmin :: SyncStatus -> SyncStatus -> SyncStatus
min :: SyncStatus -> SyncStatus -> SyncStatus
Ord, Int -> SyncStatus -> ShowS
[SyncStatus] -> ShowS
SyncStatus -> String
(Int -> SyncStatus -> ShowS)
-> (SyncStatus -> String)
-> ([SyncStatus] -> ShowS)
-> Show SyncStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SyncStatus -> ShowS
showsPrec :: Int -> SyncStatus -> ShowS
$cshow :: SyncStatus -> String
show :: SyncStatus -> String
$cshowList :: [SyncStatus] -> ShowS
showList :: [SyncStatus] -> ShowS
Show )

unmarshalSyncStatus :: GLenum -> SyncStatus
unmarshalSyncStatus :: GLenum -> SyncStatus
unmarshalSyncStatus GLenum
x
   | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_UNSIGNALED = SyncStatus
Unsignaled
   | GLenum
x GLenum -> GLenum -> Bool
forall a. Eq a => a -> a -> Bool
== GLenum
GL_SIGNALED = SyncStatus
Signaled
   | Bool
otherwise = String -> SyncStatus
forall a. HasCallStack => String -> a
error (String
"unmarshalSyncStatus: illegal value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GLenum -> String
forall a. Show a => a -> String
show GLenum
x)

syncStatus :: SyncObject -> GettableStateVar SyncStatus
syncStatus :: SyncObject -> GettableStateVar SyncStatus
syncStatus SyncObject
syncObject =
   GettableStateVar SyncStatus -> GettableStateVar SyncStatus
forall a. IO a -> IO a
makeGettableStateVar (GettableStateVar SyncStatus -> GettableStateVar SyncStatus)
-> GettableStateVar SyncStatus -> GettableStateVar SyncStatus
forall a b. (a -> b) -> a -> b
$
      GLint
-> (Ptr GLint -> GettableStateVar SyncStatus)
-> GettableStateVar SyncStatus
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with GLint
0 ((Ptr GLint -> GettableStateVar SyncStatus)
 -> GettableStateVar SyncStatus)
-> (Ptr GLint -> GettableStateVar SyncStatus)
-> GettableStateVar SyncStatus
forall a b. (a -> b) -> a -> b
$ \Ptr GLint
buf -> do
         GLsync -> GLenum -> GLint -> Ptr GLint -> Ptr GLint -> IO ()
forall (m :: * -> *).
MonadIO m =>
GLsync -> GLenum -> GLint -> Ptr GLint -> Ptr GLint -> m ()
glGetSynciv (SyncObject -> GLsync
syncID SyncObject
syncObject) GLenum
GL_SYNC_STATUS GLint
1 Ptr GLint
forall a. Ptr a
nullPtr Ptr GLint
buf
         (GLint -> SyncStatus) -> Ptr GLint -> GettableStateVar SyncStatus
forall a b. Storable a => (a -> b) -> Ptr a -> IO b
peek1 (GLenum -> SyncStatus
unmarshalSyncStatus (GLenum -> SyncStatus) -> (GLint -> GLenum) -> GLint -> SyncStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLint -> GLenum
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Ptr GLint
buf