src/Quasar/Wayland/Client/Buffer.hs

@@ -71,7 +71,7 @@ newShmBuffer shm width height = do
     wlBuffer <- wlShmPool.create_buffer offset width height stride pixelFormat
     setEventHandler wlBuffer EventHandler_wl_buffer {
       -- TODO
-      release = wlBuffer.destroy
+      release = pure () -- wlBuffer.destroy
     }
     pure wlBuffer
 

src/Quasar/Wayland/Server/Shm.hs

@@ -38,9 +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 :: STM ()
-    -- TODO handle other exceptions (e.g. disconnected)
-    releaseFn = unlessM (isDestroyed wlBuffer) wlBuffer.release
+  let initializeBufferFn = newShmBuffer pool offset width height stride format
+  initializeWlBuffer @ShmBufferBackend wlBuffer initializeBufferFn

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

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 :: STM ()
+  format :: Word32
 }
 
 -- | Create an `ShmPool` for externally managed memory. Takes ownership of the passed file descriptor.
@@ -86,11 +84,11 @@ 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 releaseFn = do
+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
 

src/Quasar/Wayland/Surface.hs

@@ -20,29 +20,30 @@ import Control.Monad.Catch
 import Data.Typeable
 import Quasar.Prelude
 import Quasar.Wayland.Protocol
-import Quasar.Wayland.Protocol.Generated
 import Quasar.Wayland.Region (Rectangle(..))
 
 type BufferBackend :: Type -> Constraint
 class Typeable b => BufferBackend b where
   type BufferContent b
-  -- | Buffer has been released and can be reused by the owner.
-  releaseBuffer :: BufferContent b -> 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,
-  lockCount :: TVar Word32,
+  -- | 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,
   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
   destroyed <- newTVar False
   pure Buffer {
     content,
+    releaseBuffer,
     lockCount,
     destroyed
   }
@@ -57,9 +58,10 @@ lockBuffer buffer = do
     unlockBuffer = do
       lockCount <- stateTVar buffer.lockCount (dup . pred)
       when (lockCount == 0) do
-        releaseBuffer @b buffer.content
+        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`).
 destroyBuffer :: forall b. BufferBackend b => Buffer b -> STM ()
 destroyBuffer buffer = do
   alreadyDestroyed <- readTVar buffer.destroyed
@@ -91,11 +93,14 @@ 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),
   surfaceState :: TVar (SurfaceCommit b),
-  lastBufferUnlockFn :: TVar (Maybe (STM ())),
+  lastBufferUnlockFn :: TVar (STM ()),
   downstreams :: TVar [SurfaceDownstream b]
 }
 
@@ -118,7 +123,7 @@ newSurface :: forall b. STM (Surface b)
 newSurface = do
   surfaceRole <- newTVar Nothing
   surfaceState <- newTVar (defaultSurfaceCommit DamageAll)
-  lastBufferUnlockFn <- newTVar Nothing
+  lastBufferUnlockFn <- newTVar (pure ())
   downstreams <- newTVar []
   pure Surface {
     surfaceRole,
@@ -139,8 +144,14 @@ assignSurfaceRole surface role = do
 
 commitSurface :: forall b. BufferBackend b => Surface b -> SurfaceCommit b -> STM ()
 commitSurface surface commit = do
-  mapM_ id =<< readTVar surface.lastBufferUnlockFn
-  writeTVar surface.lastBufferUnlockFn =<< mapM (lockBuffer @b) commit.buffer
+  join $ readTVar surface.lastBufferUnlockFn
+
+  unlockFn <-
+    case commit.buffer of
+      Just buffer -> lockBuffer @b buffer
+      Nothing -> pure (pure ())
+
+  writeTVar surface.lastBufferUnlockFn unlockFn
 
   downstreams <- readTVar surface.downstreams
   -- TODO handle exceptions, remove failed downstreams