Store disposer on ServerBuffer frame import

Fixes a problem with trivial frame disposers. This change would also
allow the reuse of ShmBuffers.

quasar-wayland-gles/src/Quasar/Wayland/Gles/Dmabuf.hs

@@ -42,7 +42,7 @@ import Foreign
 import GHC.Records
 import Quasar.Future
 import Quasar.Prelude
-import Quasar.Resources (Disposable (getDisposer))
+import Quasar.Resources (Disposable (getDisposer), Disposer)
 import Quasar.Wayland.Client
 import Quasar.Wayland.Gles.Utils.Stat (DevT(..))
 import Quasar.Wayland.Protocol
@@ -57,7 +57,7 @@ class RenderBackend b => IsDmabufBackend b where
   type MappedDmabuf b
   mapDmabuf :: b -> Dmabuf -> STMc NoRetry '[] (MappedDmabuf b)
   unmapDmabuf :: MappedDmabuf b -> STMc NoRetry '[] ()
-  createDmabufFrame :: MappedDmabuf b -> STMc NoRetry '[] (Frame b)
+  createDmabufFrame :: MappedDmabuf b -> Disposer -> STMc NoRetry '[] (Frame b)
 
 data Dmabuf = Dmabuf {
   width :: Int32,

quasar-wayland/src/Quasar/Wayland/Client/JuicyPixels.hs

@@ -10,6 +10,7 @@ import Quasar.Prelude
 import Quasar.Wayland.Client.ShmBuffer
 import Quasar.Wayland.Shared.Surface
 import Quasar.Wayland.Shm
+import Quasar.Resources (getDisposer)
 
 loadImageFile ::
   IsShmBufferBackend b =>
@@ -30,7 +31,7 @@ toImage backend image = do
   withForeignPtr ptr \ptr' -> forM_ [(x, y) | x <- [0 .. width - 1], y <- [0 .. height - 1]] \(x, y) -> do
     pokeByteOff ptr' ((x + (y * width)) * 4) (pixelRgba8ToWlARGB (pixelAt image x y))
 
-  atomicallyC (importShmBuffer backend buffer)
+  atomicallyC (importShmBuffer backend buffer (getDisposer buffer))
 
 
 pixelRgba8ToWlARGB :: PixelRGBA8 -> Word32

quasar-wayland/src/Quasar/Wayland/Server/Surface.hs

@@ -17,7 +17,7 @@ import Quasar.Wayland.Protocol.Generated
 import Quasar.Wayland.Region (appAsRect)
 import Quasar.Wayland.Shared.Surface
 import Quasar.Wayland.Protocol.Core (attachOrRunFinalizer)
-import Quasar.Resources (Disposer, getDisposer, newUnmanagedSTMDisposer, newUnmanagedTDisposer)
+import Quasar.Resources (Disposer, getDisposer, TDisposer, newUnmanagedTDisposer)
 import Quasar.Future (callOnceCompleted_, toFuture)
 
 
@@ -50,7 +50,7 @@ data MappedServerSurface b = MappedServerSurface {
 
 data ServerBuffer b = ServerBuffer {
   wlBuffer :: Object 'Server Interface_wl_buffer,
-  importBuffer :: STMc NoRetry '[] (Frame b)
+  importBuffer :: Disposer -> STMc NoRetry '[] (Frame b)
 }
 
 newServerSurface :: STMc NoRetry '[] (ServerSurface b)
@@ -114,10 +114,9 @@ commitMappedServerSurface surface mapped = do
       when (isJust frameCallback) $ throwM $ userError "Must not attach frame callback when unmapping surface"
       unmapSurfaceDownstream mapped.surfaceDownstream
     Just sb -> do
-      rawFrame <- liftSTMc sb.importBuffer
-
-      callOnceCompleted_ (toFuture (getDisposer rawFrame)) \_ -> tryCall sb.wlBuffer.release
+      frameRelease <- newUnmanagedTDisposer (tryCall sb.wlBuffer.release)
 
+      rawFrame <- liftSTMc $ sb.importBuffer (getDisposer frameRelease)
       frame <- newRc rawFrame
 
       -- TODO Instead of voiding the future we might want to delay the
@@ -203,7 +202,7 @@ addFrameCallback serverSurface wlCallback = do
 initializeWlBuffer ::
   forall b. (RenderBackend b) =>
   NewObject 'Server Interface_wl_buffer ->
-  STMc NoRetry '[] (Frame b) ->
+  (Disposer -> STMc NoRetry '[] (Frame b)) ->
   STMc NoRetry '[] () ->
   STMc NoRetry '[] ()
 initializeWlBuffer wlBuffer importBuffer finalizeBuffer = do

quasar-wayland/src/Quasar/Wayland/Shm.hs

@@ -17,7 +17,7 @@ import Data.Set (Set)
 import Data.Set qualified as Set
 import Quasar.Future
 import Quasar.Prelude
-import Quasar.Resources (TDisposer, newUnmanagedTDisposer, disposeTDisposer, Disposable(..), TDisposable, disposerElementKey, isDisposed)
+import Quasar.Resources (Disposer, TDisposer, newUnmanagedTDisposer, disposeTDisposer, Disposable(..), TDisposable, disposerElementKey, isDisposed)
 import Quasar.Resources.DisposableVar
 import Quasar.Resources.Rc
 import Quasar.Wayland.Client
@@ -29,14 +29,19 @@ import Quasar.Wayland.Shared.Surface
 -- | Simple buffer backend that only supports shared memory buffers.
 data ShmBufferBackend = ShmBufferBackend
 
+data ShmBufferFrame = ShmBufferFrame Disposer ShmBuffer
+
+instance Disposable ShmBufferFrame where
+  getDisposer (ShmBufferFrame disposer _) = disposer
+
 instance RenderBackend ShmBufferBackend where
-  type Frame ShmBufferBackend = ShmBuffer
+  type Frame ShmBufferBackend = ShmBufferFrame
 
 class RenderBackend b => IsShmBufferBackend b where
-  importShmBuffer :: b -> ShmBuffer -> STMc NoRetry '[] (Frame b)
+  importShmBuffer :: b -> ShmBuffer -> Disposer -> STMc NoRetry '[] (Frame b)
 
 instance IsShmBufferBackend ShmBufferBackend where
-  importShmBuffer ShmBufferBackend = pure
+  importShmBuffer ShmBufferBackend shmBuffer disposer = pure (ShmBufferFrame disposer shmBuffer)
 
 -- | Wrapper for an externally managed shm pool
 data ShmPool = ShmPool {
@@ -151,31 +156,31 @@ newShmBuffer pool offset width height stride format = do
 instance ClientBufferBackend ShmBufferBackend where
 
   type ClientBufferManager ShmBufferBackend = ClientShmManager
-  type RenderedFrame ShmBufferBackend = ShmBuffer
+  type RenderedFrame ShmBufferBackend = ShmBufferFrame
   type ExportBufferId ShmBufferBackend = Unique
 
   newClientBufferManager = newClientShmManager
 
-  renderFrame :: Rc ShmBuffer -> IO (Rc ShmBuffer)
+  renderFrame :: Rc ShmBufferFrame -> IO (Rc ShmBufferFrame)
   renderFrame = pure
 
-  getExportBufferId :: ShmBuffer -> STMc NoRetry '[] Unique
-  getExportBufferId (ShmBuffer var) = pure (disposerElementKey var)
+  getExportBufferId :: ShmBufferFrame -> STMc NoRetry '[] Unique
+  getExportBufferId (ShmBufferFrame _ (ShmBuffer var)) = pure (disposerElementKey var)
 
-  exportWlBuffer :: ClientShmManager -> ShmBuffer -> IO (NewObject 'Client Interface_wl_buffer)
-  exportWlBuffer client (ShmBuffer var) = atomicallyC do
+  exportWlBuffer :: ClientShmManager -> ShmBufferFrame -> IO (NewObject 'Client Interface_wl_buffer)
+  exportWlBuffer client (ShmBufferFrame _ (ShmBuffer var)) = atomicallyC do
     tryReadTDisposableVar var >>= \case
       Nothing -> throwM (userError "ShmBufferBackend: Trying to export already disposed buffer")
       Just state -> do
         wlShmPool <- getClientShmPool client state.pool
         -- NOTE no event handlers are attached here, since the caller (usually `Quasar.Wayland.Surface`) has that responsibility.
         wlShmPool.create_buffer state.offset state.width state.height state.stride state.format
 
-  syncExportBuffer :: ShmBuffer -> IO ()
+  syncExportBuffer :: ShmBufferFrame -> IO ()
   syncExportBuffer _ = pure ()
 
-  getExportBufferDestroyedFuture :: ShmBuffer -> STMc NoRetry '[] (Future '[] ())
-  getExportBufferDestroyedFuture = pure . isDisposed
+  getExportBufferDestroyedFuture :: ShmBufferFrame -> STMc NoRetry '[] (Future '[] ())
+  getExportBufferDestroyedFuture (ShmBufferFrame _ shmBuffer) = pure $ isDisposed shmBuffer
 
 data ClientShmManager = ClientShmManager {
   key :: Unique,