Simplify buffer release event handling

src/Quasar/Wayland/Server/Shm.hs

@@ -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

src/Quasar/Wayland/Server/Surface.hs

@@ -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)

src/Quasar/Wayland/Shm.hs

@@ -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
 

src/Quasar/Wayland/Surface.hs

@@ -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`).