From 28acdd07c886f5c1b533baa3606d1b2dc228c6d5 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Fri, 19 Aug 2022 21:50:54 +0200
Subject: [PATCH] Count attach/release events in the server module
---
src/Quasar/Wayland/Server/Shm.hs | 10 +--
src/Quasar/Wayland/Server/Surface.hs | 114 ++++++++++++++++-----------
src/Quasar/Wayland/Shm.hs | 12 ++-
src/Quasar/Wayland/Surface.hs | 24 +++---
4 files changed, 85 insertions(+), 75 deletions(-)
diff --git a/src/Quasar/Wayland/Server/Shm.hs b/src/Quasar/Wayland/Server/Shm.hs
index 74728ba..65234b9 100644
--- a/src/Quasar/Wayland/Server/Shm.hs
+++ b/src/Quasar/Wayland/Server/Shm.hs
@@ -38,11 +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
- shmBuffer <- newShmBuffer pool offset width height stride format releaseFn
- initializeWlBuffer @ShmBufferBackend wlBuffer shmBuffer
- where
- releaseFn :: Int -> STM ()
- -- TODO handle other exceptions (e.g. disconnected)
- releaseFn attachedCount =
- unlessM (isDestroyed wlBuffer)
- (sequence_ (replicate attachedCount wlBuffer.release))
+ let initializeBufferFn = newShmBuffer pool offset width height stride format
+ initializeWlBuffer @ShmBufferBackend wlBuffer initializeBufferFn
diff --git a/src/Quasar/Wayland/Server/Surface.hs b/src/Quasar/Wayland/Server/Surface.hs
index 84719f3..8144428 100644
--- a/src/Quasar/Wayland/Server/Surface.hs
+++ b/src/Quasar/Wayland/Server/Surface.hs
@@ -14,69 +14,73 @@ import Quasar.Wayland.Surface
data ServerSurface b = ServerSurface {
surface :: Surface b,
- pendingSurfaceCommit :: TVar (SurfaceCommit b),
+ pendingBuffer :: TVar (Maybe (ServerBuffer b)),
+ pendingOffset :: TVar (Int32, Int32),
+ pendingBufferDamage :: TVar Damage,
-- Damage specified in surface coordinates (i.e. produced by wl_surface.damage instead of wl_surface.damage_buffer).
-- Damage can be converted to buffer coordinates on commit (NOTE: conversion requires wl_surface version 4)
pendingSurfaceDamage :: TVar [Rectangle]
}
+data ServerBuffer b = ServerBuffer {
+ buffer :: Buffer b,
+ attachedCount :: TVar Int
+}
+
newServerSurface :: forall b. STM (ServerSurface b)
newServerSurface = do
surface <- newSurface @b
- pendingSurfaceCommit <- newTVar (defaultSurfaceCommit (DamageList []))
- pendingSurfaceDamage <- newTVar []
+ pendingBuffer <- newTVar Nothing
+ pendingOffset <- newTVar (0, 0)
+ pendingBufferDamage <- newTVar mempty
+ pendingSurfaceDamage <- newTVar mempty
+
pure ServerSurface {
surface,
- pendingSurfaceCommit,
+ pendingBuffer,
+ pendingOffset,
+ pendingBufferDamage,
pendingSurfaceDamage
}
-modifyPending :: forall b. ServerSurface b -> (SurfaceCommit b -> SurfaceCommit b) -> STM ()
-modifyPending surface fn = modifyTVar surface.pendingSurfaceCommit fn
-
commitServerSurface :: forall b. BufferBackend b => ServerSurface b -> STM ()
commitServerSurface surface = do
- pendingCommit <- readTVar surface.pendingSurfaceCommit
-
+ serverBuffer <- swapTVar surface.pendingBuffer Nothing
+ offset <- swapTVar surface.pendingOffset (0, 0)
+ bufferDamage <- swapTVar surface.pendingBufferDamage mempty
surfaceDamage <- swapTVar surface.pendingSurfaceDamage mempty
- let convertedSurfaceDamage =
- case surfaceDamage of
- [] -> DamageList []
- -- TODO should do a coordinate conversion
- _ -> DamageAll
-
- let commit =
- pendingCommit {
- bufferDamage = pendingCommit.bufferDamage <> convertedSurfaceDamage
- }
-
- writeTVar surface.pendingSurfaceCommit $
- commit {
- buffer = Nothing,
- offset = (0, 0),
- bufferDamage = DamageList []
- }
-
- commitSurface surface.surface commit
+ let
+ convertedSurfaceDamage =
+ case surfaceDamage of
+ [] -> mempty
+ -- TODO should do a coordinate conversion
+ _ -> DamageAll
+ combinedDamage = bufferDamage <> convertedSurfaceDamage
+
+ 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
- buffer <- mapM (getBuffer @b) wlBuffer
- modifyPending surface \s ->
- s {
- buffer,
- offset = (x, y)
- }
+ buffer <- mapM (getServerBuffer @b) wlBuffer
+ writeTVar surface.pendingBuffer buffer
+ writeTVar surface.pendingOffset (x, y)
damageSurface :: forall b. ServerSurface b -> Rectangle -> STM ()
-damageSurface surface rect =
- modifyTVar surface.pendingSurfaceDamage (rect:)
+damageSurface surface rect = modifyTVar surface.pendingSurfaceDamage (rect:)
damageBuffer :: forall b. ServerSurface b -> Rectangle -> STM ()
damageBuffer surface rect =
- modifyPending surface \case
- commit@SurfaceCommit{bufferDamage = DamageAll} -> commit
- commit@SurfaceCommit{bufferDamage = DamageList xs} -> commit { bufferDamage = DamageList (rect : xs) }
+ modifyTVar surface.pendingBufferDamage \case
+ DamageAll -> DamageAll
+ DamageList xs -> DamageList (rect : xs)
initializeServerSurface :: forall b. BufferBackend b => Object 'Server Interface_wl_surface -> STM ()
@@ -99,17 +103,35 @@ initializeServerSurface wlSurface = do
setInterfaceData wlSurface surface
traceM "wl_surface not implemented"
-initializeWlBuffer :: forall b. BufferBackend b => NewObject 'Server Interface_wl_buffer -> Buffer b -> STM ()
-initializeWlBuffer wlBuffer buffer = do
- setInterfaceData wlBuffer buffer
+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)
+
+ let serverBuffer = ServerBuffer {
+ buffer,
+ attachedCount
+ }
+ setInterfaceData wlBuffer serverBuffer
setRequestHandler wlBuffer RequestHandler_wl_buffer {
-- TODO propagate buffer destruction
destroy = destroyBuffer buffer
}
-
-getBuffer :: forall b. BufferBackend b => Object 'Server Interface_wl_buffer -> STM (Buffer b)
-getBuffer wlBuffer = do
- ifd <- getInterfaceData @(Buffer b) wlBuffer
+ 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)
+getServerBuffer wlBuffer = do
+ ifd <- getInterfaceData @(ServerBuffer b) wlBuffer
case ifd of
Just buffer -> pure buffer
Nothing -> throwM $ InternalError ("Missing interface data on " <> show wlBuffer)
+
+getBuffer :: forall b. BufferBackend b => Object 'Server Interface_wl_buffer -> STM (Buffer b)
+getBuffer wlBuffer = (.buffer) <$> getServerBuffer wlBuffer
diff --git a/src/Quasar/Wayland/Shm.hs b/src/Quasar/Wayland/Shm.hs
index ce5a714..7114f22 100644
--- a/src/Quasar/Wayland/Shm.hs
+++ b/src/Quasar/Wayland/Shm.hs
@@ -17,7 +17,6 @@ data ShmBufferBackend
instance BufferBackend ShmBufferBackend where
type BufferContent ShmBufferBackend = ShmBuffer
- releaseBuffer buffer = buffer.releaseFn
releaseBufferStorage buffer = do
modifyTVar buffer.pool.bufferCount pred
traceM "Finalized ShmBuffer"
@@ -39,8 +38,7 @@ data ShmBuffer = ShmBuffer {
width :: Int32,
height :: Int32,
stride :: Int32,
- format :: Word32,
- releaseFn :: Int -> STM ()
+ format :: Word32
}
-- | Create an `ShmPool` for externally managed memory. Takes ownership of the passed file descriptor.
@@ -85,12 +83,12 @@ tryFinalizeShmPool pool = do
-- | Create a new buffer for an externally managed pool
-newShmBuffer :: ShmPool -> Int32 -> Int32 -> Int32 -> Int32 -> Word32 -> (Int -> STM ()) -> STM (Buffer ShmBufferBackend)
-newShmBuffer pool offset width height stride format releaseFn = do
+newShmBuffer :: ShmPool -> Int32 -> Int32 -> Int32 -> Int32 -> Word32 -> STM () -> STM (Buffer ShmBufferBackend)
+newShmBuffer pool offset width height stride format releaseBuffer = do
-- TODO check arguments
modifyTVar pool.bufferCount succ
- let shmBuffer = ShmBuffer pool offset width height stride format releaseFn
- newBuffer @ShmBufferBackend shmBuffer
+ let shmBuffer = ShmBuffer pool offset width height stride format
+ newBuffer @ShmBufferBackend shmBuffer releaseBuffer
data DownstreamShmPool = DownstreamShmPool
diff --git a/src/Quasar/Wayland/Surface.hs b/src/Quasar/Wayland/Surface.hs
index 9471424..d779193 100644
--- a/src/Quasar/Wayland/Surface.hs
+++ b/src/Quasar/Wayland/Surface.hs
@@ -25,30 +25,26 @@ import Quasar.Wayland.Region (Rectangle(..))
type BufferBackend :: Type -> Constraint
class Typeable b => BufferBackend b where
type BufferContent b
- -- | Buffer has been released by all current users and can be reused by the owner.
- -- Wayland requires a release event per attach, so a counter provides the number of times the buffer was attached.
- releaseBuffer :: BufferContent b -> Int -> STM ()
-- | A destroyed buffer has been released, so the buffer storage can be freed by the owner.
releaseBufferStorage :: BufferContent b -> STM ()
data Buffer b = Buffer {
content :: BufferContent b,
+ -- | Buffer has been released by all current users and can be reused by the owner.
+ releaseBuffer :: STM (),
-- | Refcount that tracks how many times the buffer is locked by consumers.
lockCount :: TVar Int,
- -- | Tracks how often the buffer has been attached (wl_surface.attach + wl_surface.commit). Wayland requires one `release` event for each time a buffer is attached.
- attachedCount :: TVar Int,
destroyed :: TVar Bool
}
-newBuffer :: forall b. BufferContent b -> STM (Buffer b)
-newBuffer content = do
+newBuffer :: forall b. BufferContent b -> STM () -> STM (Buffer b)
+newBuffer content releaseBuffer = do
lockCount <- newTVar 0
- attachedCount <- newTVar 0
destroyed <- newTVar False
pure Buffer {
content,
+ releaseBuffer,
lockCount,
- attachedCount,
destroyed
}
@@ -62,8 +58,7 @@ lockBuffer buffer = do
unlockBuffer = do
lockCount <- stateTVar buffer.lockCount (dup . pred)
when (lockCount == 0) do
- attachedCount <- swapTVar buffer.attachedCount 0
- releaseBuffer @b buffer.content attachedCount
+ buffer.releaseBuffer
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`).
@@ -98,6 +93,9 @@ instance Semigroup Damage where
_ <> DamageAll = DamageAll
DamageList xs <> DamageList ys = DamageList (xs <> ys)
+instance Monoid Damage where
+ mempty = DamageList []
+
data Surface b = Surface {
surfaceRole :: TVar (Maybe SomeSurfaceRole),
@@ -150,9 +148,7 @@ commitSurface surface commit = do
unlockFn <-
case commit.buffer of
- Just buffer -> do
- modifyTVar buffer.attachedCount succ
- lockBuffer @b buffer
+ Just buffer -> lockBuffer @b buffer
Nothing -> pure (pure ())
writeTVar surface.lastBufferUnlockFn unlockFn
--
GitLab