Skip to content
Snippets Groups Projects
Commit 1d786a13 authored by Jens Nolte's avatar Jens Nolte
Browse files

Simplify buffer release event handling

parent 28acdd07
No related branches found
No related tags found
No related merge requests found
......@@ -38,5 +38,5 @@ initializeWlShmPool wlShmPool fd size = do
initializeWlShmBuffer :: ShmPool -> NewObject 'Server Interface_wl_buffer -> Int32 -> Int32 -> Int32 -> Int32 -> Word32 -> STM ()
initializeWlShmBuffer pool wlBuffer offset width height stride format = do
let initializeBufferFn = newShmBuffer pool offset width height stride format
initializeWlBuffer @ShmBufferBackend wlBuffer initializeBufferFn
buffer <- newShmBuffer pool offset width height stride format
initializeWlBuffer @ShmBufferBackend wlBuffer buffer
......@@ -24,7 +24,7 @@ data ServerSurface b = ServerSurface {
data ServerBuffer b = ServerBuffer {
buffer :: Buffer b,
attachedCount :: TVar Int
wlBuffer :: Object 'Server Interface_wl_buffer
}
newServerSurface :: forall b. STM (ServerSurface b)
......@@ -57,15 +57,16 @@ commitServerSurface surface = do
_ -> DamageAll
combinedDamage = bufferDamage <> convertedSurfaceDamage
-- Attach callback for wl_buffer.release
forM_ serverBuffer \sb ->
addBufferReleaseCallback sb.buffer sb.wlBuffer.release
commitSurface surface.surface SurfaceCommit {
buffer = (.buffer) <$> serverBuffer,
offset,
bufferDamage = combinedDamage
}
case serverBuffer of
Just sb -> modifyTVar sb.attachedCount (+ 1)
Nothing -> pure ()
attachToSurface :: forall b. BufferBackend b => ServerSurface b -> Maybe (Object 'Server Interface_wl_buffer) -> Int32 -> Int32 -> STM ()
attachToSurface surface wlBuffer x y = do
......@@ -103,27 +104,17 @@ initializeServerSurface wlSurface = do
setInterfaceData wlSurface surface
traceM "wl_surface not implemented"
initializeWlBuffer :: forall b. BufferBackend b => NewObject 'Server Interface_wl_buffer -> (STM () -> STM (Buffer b)) -> STM ()
initializeWlBuffer wlBuffer initializeBufferFn = do
attachedCount <- newTVar 0
buffer <- initializeBufferFn (releaseServerBuffer attachedCount)
initializeWlBuffer :: forall b. BufferBackend b => NewObject 'Server Interface_wl_buffer -> Buffer b -> STM ()
initializeWlBuffer wlBuffer buffer = do
let serverBuffer = ServerBuffer {
buffer,
attachedCount
wlBuffer
}
setInterfaceData wlBuffer serverBuffer
setRequestHandler wlBuffer RequestHandler_wl_buffer {
-- TODO propagate buffer destruction
destroy = destroyBuffer buffer
}
where
releaseServerBuffer :: TVar Int -> STM ()
releaseServerBuffer attachedCountVar = do
attachedCount <- swapTVar attachedCountVar 0
-- TODO handle other exceptions (e.g. disconnects)
unlessM (isDestroyed wlBuffer) $
sequence_ $ replicate attachedCount $ wlBuffer.release
getServerBuffer :: forall b. BufferBackend b => Object 'Server Interface_wl_buffer -> STM (ServerBuffer b)
......
......@@ -83,12 +83,12 @@ tryFinalizeShmPool pool = do
-- | Create a new buffer for an externally managed pool
newShmBuffer :: ShmPool -> Int32 -> Int32 -> Int32 -> Int32 -> Word32 -> STM () -> STM (Buffer ShmBufferBackend)
newShmBuffer pool offset width height stride format releaseBuffer = do
newShmBuffer :: ShmPool -> Int32 -> Int32 -> Int32 -> Int32 -> Word32 -> STM (Buffer ShmBufferBackend)
newShmBuffer pool offset width height stride format = do
-- TODO check arguments
modifyTVar pool.bufferCount succ
let shmBuffer = ShmBuffer pool offset width height stride format
newBuffer @ShmBufferBackend shmBuffer releaseBuffer
newBuffer @ShmBufferBackend shmBuffer
data DownstreamShmPool = DownstreamShmPool
......
......@@ -5,6 +5,7 @@ module Quasar.Wayland.Surface (
newBuffer,
lockBuffer,
destroyBuffer,
addBufferReleaseCallback,
-- * Surface
Damage(..),
......@@ -31,14 +32,15 @@ class Typeable b => BufferBackend b where
data Buffer b = Buffer {
content :: BufferContent b,
-- | Buffer has been released by all current users and can be reused by the owner.
releaseBuffer :: STM (),
releaseBuffer :: TVar (STM ()),
-- | Refcount that tracks how many times the buffer is locked by consumers.
lockCount :: TVar Int,
destroyed :: TVar Bool
}
newBuffer :: forall b. BufferContent b -> STM () -> STM (Buffer b)
newBuffer content releaseBuffer = do
newBuffer :: forall b. BufferContent b -> STM (Buffer b)
newBuffer content = do
releaseBuffer <- newTVar (pure ())
lockCount <- newTVar 0
destroyed <- newTVar False
pure Buffer {
......@@ -48,6 +50,12 @@ newBuffer content releaseBuffer = do
destroyed
}
addBufferReleaseCallback :: Buffer b -> STM () -> STM ()
addBufferReleaseCallback buffer releaseFn =
modifyTVar buffer.releaseBuffer (>> releaseFn)
-- | Prevents the buffer from being released. Returns an unlock action.
lockBuffer :: forall b. BufferBackend b => Buffer b -> STM (STM ())
lockBuffer buffer = do
......@@ -58,7 +66,7 @@ lockBuffer buffer = do
unlockBuffer = do
lockCount <- stateTVar buffer.lockCount (dup . pred)
when (lockCount == 0) do
buffer.releaseBuffer
join $ swapTVar buffer.releaseBuffer (pure ())
tryFinalizeBuffer @b buffer
-- | Request destruction of the buffer. Since the buffer might still be in use downstream, the backing storage must not be changed until all downstreams release the buffer (signalled by `releaseBufferStorage`).
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment