Remove redundant Borrowed disposer from ExternalBuffer

quasar-wayland-skia/src/Quasar/Wayland/Skia.hs

@@ -192,13 +192,13 @@ instance Disposable (SkiaFrameState s) where
   getDisposer (SkiaFrameSparked disposer _) = disposer
 
 data SkiaFrameOp s
-  = SkiaFrameExternalDmabuf (Skia s) TDisposer (Rc ExternalDmabuf)
+  = SkiaFrameExternalDmabuf (Skia s) (Borrowed ExternalDmabuf)
   --- | SkiaFrameShaderOp
   --- | SkiaFrameExported (Rc (SkiaExportBuffer s))
   | SkiaFrameSinglePixel SinglePixelBuffer
 
 instance Disposable (SkiaFrameOp s) where
-  getDisposer (SkiaFrameExternalDmabuf _ disposer rc) = getDisposer disposer <> getDisposer rc
+  getDisposer (SkiaFrameExternalDmabuf _ borrowed) = getDisposer borrowed
   getDisposer (SkiaFrameSinglePixel _) = mempty
 
 
@@ -209,13 +209,13 @@ data SkiaRenderedFrame s
   -- Borrowed surface, i.e. a surface that is used by the frame and will be
   -- "returned" to the owner once the frame is destroyed.
   | SkiaRenderedFrameBorrowedSurface (Borrowed (SkiaSurface s))
-  | SkiaRenderedFrameImportedDmabuf TDisposer (SkiaImage s) (Rc ExternalDmabuf)
+  | SkiaRenderedFrameImportedDmabuf (SkiaImage s) (Borrowed ExternalDmabuf)
   | SkiaRenderedFrameSinglePixel SinglePixelBuffer
 
 instance Disposable (SkiaRenderedFrame s) where
   getDisposer (SkiaRenderedFrameOwnedSurface surface) = getDisposer surface
   getDisposer (SkiaRenderedFrameBorrowedSurface rc) = getDisposer rc
-  getDisposer (SkiaRenderedFrameImportedDmabuf disposer image rc) = getDisposer disposer <> getDisposer image <> getDisposer rc
+  getDisposer (SkiaRenderedFrameImportedDmabuf image borrowed) = getDisposer image <> getDisposer borrowed
   getDisposer (SkiaRenderedFrameSinglePixel _) = mempty
 
 newtype SkiaClientBufferManager s = SkiaClientBufferManager {
@@ -259,16 +259,15 @@ instance IsSkiaBackend s => ClientBufferBackend (Skia s) where
     pure (SkiaExportBufferIdUnique (skiaSurfaceKey surface))
   getExportBufferId (SkiaRenderedFrameBorrowedSurface (Borrowed _ surface)) =
     pure (SkiaExportBufferIdUnique (skiaSurfaceKey surface))
-  getExportBufferId (SkiaRenderedFrameImportedDmabuf _ _ rc) = do
-    (ExternalDmabuf key _) <- readRc rc
+  getExportBufferId (SkiaRenderedFrameImportedDmabuf _ (Borrowed _ (ExternalDmabuf key _))) = do
     pure (SkiaExportBufferIdUnique key)
   getExportBufferId (SkiaRenderedFrameSinglePixel pixel) = pure (SkiaExportBufferIdSinglePixel pixel)
 
   exportWlBuffer :: SkiaClientBufferManager s -> SkiaRenderedFrame s -> IO (NewObject 'Client Interface_wl_buffer)
   exportWlBuffer manager renderedFrame =
     atomicallyC (getExportBuffer renderedFrame) >>= \case
       SkiaExportBufferSurface surface -> exportSkiaSurface manager surface
-      SkiaExportBufferImportedDmabuf (ExternalDmabuf _ (Borrowed _ dmabuf)) ->
+      SkiaExportBufferImportedDmabuf (ExternalDmabuf _ dmabuf) ->
         atomicallyC $ sharedDmabufExportWlBuffer manager.dmabufSingleton dmabuf
       SkiaExportBufferSinglePixel pixel -> undefined
 
@@ -295,10 +294,8 @@ getExportBuffer (SkiaRenderedFrameOwnedSurface surface) =
   pure (SkiaExportBufferSurface surface)
 getExportBuffer (SkiaRenderedFrameBorrowedSurface (Borrowed _ surface)) =
   pure (SkiaExportBufferSurface surface)
-getExportBuffer (SkiaRenderedFrameImportedDmabuf _ _ rc) = do
-  tryReadRc rc >>= \case
-    Nothing -> undefined
-    Just externalDmabuf -> pure (SkiaExportBufferImportedDmabuf externalDmabuf)
+getExportBuffer (SkiaRenderedFrameImportedDmabuf _ (Borrowed _ externalDmabuf)) = do
+  pure (SkiaExportBufferImportedDmabuf externalDmabuf)
 getExportBuffer (SkiaRenderedFrameSinglePixel pixel) =
   pure (SkiaExportBufferSinglePixel pixel)
 
@@ -318,22 +315,24 @@ renderFrameInternal frameRc = do
         Just (SkiaFrameLazy op) -> do
           frc <- cacheFuture =<< sparkFrameOp op
           disposer <- futureDisposerGeneric frc
+          -- Prevents the SkiaFrameOp from being disposed with the frame, which
+          -- is correct since ownership of the SkiaFrameOp has been passed to
+          -- `sparkFrameOp`.
           tryWriteDisposableVar var (SkiaFrameSparked disposer frc)
           pure frc
     renderedFrameRc <- await frc
     atomically do
-      tryDuplicateRc renderedFrameRc >>= \case
-        Nothing ->
-          -- We are holding an Rc (via `consumeRc`), which holds the SkiaFrame,
-          -- which holds the Rc for the SkiaRenderedFrame. If this exception
-          -- is encountered, someone somewhere disposed the SkiaFrame directly,
-          -- which is a bug.
-          throwC mkDisposedException
-        Just duplicatedRc -> pure duplicatedRc
-
+      -- We are holding an Rc (via `consumeRc`), which holds the SkiaFrame,
+      -- which holds the Rc for the SkiaRenderedFrame. This path therefore
+      -- _should_ never throw an DisposedException. If this exception is
+      -- encountered, someone somewhere disposed the SkiaFrame directly
+      -- (ignoring the Rc-based shared ownership), which would be a bug.
+      duplicateRc renderedFrameRc
+
+-- Takes ownership of the SkiaFrameOp.
 sparkFrameOp :: IsSkiaBackend s => SkiaFrameOp s -> STM (Future '[AsyncException] (Rc (SkiaRenderedFrame s)))
-sparkFrameOp (SkiaFrameExternalDmabuf skia frameRelease rc) =
-  queueSkiaIO skia.thread (importDmabuf skia frameRelease rc)
+sparkFrameOp (SkiaFrameExternalDmabuf skia borrowedExternalBuffer) =
+  queueSkiaIO skia.thread (importDmabuf skia borrowedExternalBuffer)
 sparkFrameOp (SkiaFrameSinglePixel singlePixelBuffer) =
   pure <$> newRc (SkiaRenderedFrameSinglePixel singlePixelBuffer)
 
@@ -370,14 +369,12 @@ instance Disposable ExternalShmBuffer where
 instance IsSkiaBackend s => IsBufferBackend ShmBuffer (Skia s) where
   type ExternalBuffer ShmBuffer (Skia s) = ExternalShmBuffer
 
-  newExternalBuffer :: Skia s -> Borrowed ShmBuffer -> STMc NoRetry '[] ExternalShmBuffer
-  newExternalBuffer _skia dmabuf = undefined
-    --key <- newUniqueSTM
-    --pure (ExternalDmabuf key dmabuf)
+  newExternalBuffer :: Skia s -> ShmBuffer -> STMc NoRetry '[] ExternalShmBuffer
+  newExternalBuffer _skia shmBuffer = undefined
+
+  createExternalBufferFrame :: Skia s -> Borrowed ExternalShmBuffer -> STMc NoRetry '[] (SkiaFrame s)
+  createExternalBufferFrame skia borrowed = undefined
 
-  createExternalBufferFrame :: Skia s -> TDisposer -> Rc ExternalShmBuffer -> STMc NoRetry '[] (SkiaFrame s)
-  createExternalBufferFrame skia tdisposer rc = undefined
-    --newSkiaFrame (SkiaFrameExternalDmabuf skia tdisposer rc)
 
 
 
@@ -387,33 +384,30 @@ data SkiaDmabufProperties = SkiaDmabufProperties {
   feedback :: CompiledDmabufFeedback
 }
 
-data ExternalDmabuf = ExternalDmabuf Unique (Borrowed Dmabuf)
+data ExternalDmabuf = ExternalDmabuf Unique Dmabuf
 
 instance Disposable ExternalDmabuf where
-  getDisposer (ExternalDmabuf key borrow) = getDisposer borrow
+  getDisposer (ExternalDmabuf _ borrow) = getDisposer borrow
 
 
 instance IsSkiaBackend s => IsBufferBackend Dmabuf (Skia s) where
   type ExternalBuffer Dmabuf (Skia s) = ExternalDmabuf
 
-  newExternalBuffer :: Skia s -> Borrowed Dmabuf -> STMc NoRetry '[] ExternalDmabuf
+  newExternalBuffer :: Skia s -> Dmabuf -> STMc NoRetry '[] ExternalDmabuf
   newExternalBuffer _skia dmabuf = do
     key <- newUniqueSTM
     pure (ExternalDmabuf key dmabuf)
 
-  createExternalBufferFrame :: Skia s -> TDisposer -> Rc ExternalDmabuf -> STMc NoRetry '[] (SkiaFrame s)
-  createExternalBufferFrame skia tdisposer rc = do
-    newSkiaFrame (SkiaFrameExternalDmabuf skia tdisposer rc)
+  createExternalBufferFrame :: Skia s -> Borrowed ExternalDmabuf -> STMc NoRetry '[] (SkiaFrame s)
+  createExternalBufferFrame skia borrowed = do
+    newSkiaFrame (SkiaFrameExternalDmabuf skia borrowed)
 
-importDmabuf :: IsSkiaBackend s => Skia s -> TDisposer -> Rc ExternalDmabuf -> SkiaIO (Rc (SkiaRenderedFrame s))
-importDmabuf skia frameRelease rc = do
-  atomicallyC (tryReadRc rc) >>= \case
-    Nothing -> undefined
-    Just (ExternalDmabuf _ (Borrowed _ dmabuf)) -> do
-      skImage <- skiaImportDmabuf skia dmabuf
-      skiaImage <- liftIO $ newSkiaImage skia skImage
+importDmabuf :: IsSkiaBackend s => Skia s -> Borrowed ExternalDmabuf -> SkiaIO (Rc (SkiaRenderedFrame s))
+importDmabuf skia x@(Borrowed _ (ExternalDmabuf _ dmabuf)) = do
+  skImage <- skiaImportDmabuf skia dmabuf
+  skiaImage <- liftIO $ newSkiaImage skia skImage
 
-      liftIO $ newRcIO (SkiaRenderedFrameImportedDmabuf frameRelease skiaImage rc)
+  liftIO $ newRcIO (SkiaRenderedFrameImportedDmabuf skiaImage x)
 
 
 newSkiaImage :: Skia s -> Ptr SkImage -> IO (SkiaImage s)

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

@@ -12,6 +12,7 @@ module Quasar.Wayland.Server.Surface (
 ) where
 
 import Control.Monad.Catch
+import Quasar.Exceptions
 import Quasar.Prelude
 import Quasar.Resources
 import Quasar.Resources.Rc
@@ -53,7 +54,7 @@ data MappedServerSurface b = MappedServerSurface {
 
 data ServerBuffer b = ServerBuffer {
   wlBuffer :: Object 'Server Interface_wl_buffer,
-  createFrame :: TDisposer -> STMc NoRetry '[] (Frame b)
+  createFrame :: TDisposer -> STMc NoRetry '[DisposedException] (Frame b)
 }
 
 newServerSurface :: STMc NoRetry '[] (ServerSurface b)
@@ -223,7 +224,7 @@ initializeWlBuffer ::
   buffer ->
   STMc NoRetry '[] ()
 initializeWlBuffer backend wlBuffer buffer = do
-  mappedBuffer <- newExternalBuffer backend (Borrowed (getDisposer buffer) buffer)
+  mappedBuffer <- newExternalBuffer backend buffer
   rc <- newRc mappedBuffer
   let serverBuffer = ServerBuffer {
     wlBuffer,
@@ -234,19 +235,24 @@ initializeWlBuffer backend wlBuffer buffer = do
     destroy = pure ()
   }
   -- TODO This removes back pressure for released buffers. We should await the
-  -- @unmapBufferDisposer@ somewhere in the chain of new buffer allocations.
+  -- disposer somewhere in the chain of new buffer allocations.
   -- The best place would probably be to delay the frame callback, but I'm not
-  -- sure how to do that properly and cleanly.
+  -- sure how to do that in a clean way.
+  -- We don't want to delay the whole rendering backend (since that could be
+  -- rendering content for/from multiple clients).
   attachOrRunFinalizer wlBuffer (disposeEventually_ rc)
 
   where
+    createFrameImpl :: Rc (ExternalBuffer buffer backend) -> TDisposer -> STMc NoRetry '[DisposedException] (Frame backend)
     createFrameImpl rc frameRelease = do
-      tryDuplicateRc rc >>= \case
-        Nothing ->
-          -- Frame was created from an unmapped buffer, which would probably be
-          -- a bug somewhere in this module.
-          undefined
-        Just dupedRc -> createExternalBufferFrame @buffer @backend backend frameRelease dupedRc
+      -- If duplicating the frame rc fails, the frame was created from an
+      -- unmapped buffer, which would probably be a bug somewhere in this module.
+      dupedRc <- duplicateRc rc
+      externalBuffer <- readRc dupedRc
+      let combinedRelease = getDisposer frameRelease <> getDisposer dupedRc
+      liftSTMc do
+        createExternalBufferFrame @buffer @backend backend
+          (Borrowed combinedRelease externalBuffer)
 
 
 getServerBuffer :: forall b. RenderBackend b => Object 'Server Interface_wl_buffer -> STMc NoRetry '[SomeException] (ServerBuffer b)

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

@@ -35,11 +35,12 @@ class (RenderBackend backend, Disposable (ExternalBuffer buffer backend)) => IsB
   type ExternalBuffer buffer backend
   -- | Import an external buffer. The buffer may be mutable shared memory.
   --
-  -- Takes ownership of the provided `Borrowed`-object.
+  -- Takes ownership of the provided buffer object (the buffer has to be
+  -- by the ExternalBuffer when that is disposed).
   --
   -- Ownership of the resulting @ExternalBuffer@-object is transferred to the
   -- caller, who will `dispose` it later.
-  newExternalBuffer :: backend -> Borrowed buffer -> STMc NoRetry '[] (ExternalBuffer buffer backend)
+  newExternalBuffer :: Disposable buffer => backend -> buffer -> STMc NoRetry '[] (ExternalBuffer buffer backend)
 
   -- | Create a frame from an @ExternalBuffer@.
   --
@@ -48,7 +49,7 @@ class (RenderBackend backend, Disposable (ExternalBuffer buffer backend)) => IsB
   --
   -- Ownership of the `ExternalBuffer` rc is transferred to the frame, it has
   -- to be disposed when the frame is disposed.
-  createExternalBufferFrame :: backend -> TDisposer -> Rc (ExternalBuffer buffer backend) -> STMc NoRetry '[] (Frame backend)
+  createExternalBufferFrame :: backend -> Borrowed (ExternalBuffer buffer backend) -> STMc NoRetry '[] (Frame backend)
 
 
 -- | Create a new frame by taking ownership of a buffer. The buffer will be
@@ -57,9 +58,8 @@ class (RenderBackend backend, Disposable (ExternalBuffer buffer backend)) => IsB
 -- The caller takes ownership of the resulting frame.
 newFrameConsumeBuffer :: forall buffer backend. (IsBufferBackend buffer backend, Disposable buffer) => backend -> buffer -> STMc NoRetry '[] (Frame backend)
 newFrameConsumeBuffer backend buffer = do
-  externalBuffer <- newExternalBuffer backend (Borrowed (getDisposer buffer) buffer)
-  rc <- newRc externalBuffer
-  createExternalBufferFrame @buffer backend mempty rc
+  externalBuffer <- newExternalBuffer backend buffer
+  createExternalBufferFrame @buffer backend (Borrowed (getDisposer externalBuffer) externalBuffer)
 
 
 data Damage = DamageAll | DamageList [Rectangle]

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

@@ -29,23 +29,23 @@ import Quasar.Wayland.Utils.Resources
 -- | Simple buffer backend that only supports shared memory buffers.
 data ShmBufferBackend = ShmBufferBackend
 
-data ShmBufferFrame = ShmBufferFrame TDisposer (Rc (Borrowed ShmBuffer))
+newtype ShmBufferFrame = ShmBufferFrame (Borrowed ShmBuffer)
 
 instance Disposable ShmBufferFrame where
-  getDisposer (ShmBufferFrame tdisposer rc) = getDisposer tdisposer <> getDisposer rc
+  getDisposer (ShmBufferFrame borrowed) = getDisposer borrowed
 
 instance RenderBackend ShmBufferBackend where
   type Frame ShmBufferBackend = ShmBufferFrame
 
 type IsShmBufferBackend b = IsBufferBackend ShmBuffer b
 
 instance IsBufferBackend ShmBuffer ShmBufferBackend where
-  type ExternalBuffer ShmBuffer ShmBufferBackend = Borrowed ShmBuffer
-  newExternalBuffer :: ShmBufferBackend -> Borrowed ShmBuffer -> STMc NoRetry '[] (Borrowed ShmBuffer)
-  newExternalBuffer ShmBufferBackend borrowed = pure borrowed
-  createExternalBufferFrame :: ShmBufferBackend -> TDisposer -> Rc (Borrowed ShmBuffer) -> STMc NoRetry '[] ShmBufferFrame
-  createExternalBufferFrame ShmBufferBackend frameRelease rc =
-    pure (ShmBufferFrame frameRelease rc)
+  type ExternalBuffer ShmBuffer ShmBufferBackend = ShmBuffer
+  newExternalBuffer :: ShmBufferBackend -> ShmBuffer -> STMc NoRetry '[] ShmBuffer
+  newExternalBuffer ShmBufferBackend shmBuffer = pure shmBuffer
+  createExternalBufferFrame :: ShmBufferBackend -> Borrowed ShmBuffer -> STMc NoRetry '[] ShmBufferFrame
+  createExternalBufferFrame ShmBufferBackend borrowed =
+    pure (ShmBufferFrame borrowed)
 
 -- | Wrapper for an externally managed shm pool
 data ShmPool = ShmPool {
@@ -120,26 +120,21 @@ instance ClientBufferBackend ShmBufferBackend where
   renderFrame :: Rc ShmBufferFrame -> IO (Rc ShmBufferFrame)
   renderFrame = pure
 
-  getExportBufferId :: HasCallStack => ShmBufferFrame -> STMc NoRetry '[DisposedException] Unique
-  getExportBufferId (ShmBufferFrame _ bufferRc) = do
-    (Borrowed _ buffer) <- readRc bufferRc
-    pure buffer.key
+  getExportBufferId :: ShmBufferFrame -> STMc NoRetry '[DisposedException] Unique
+  getExportBufferId (ShmBufferFrame (Borrowed _ buffer)) = pure buffer.key
 
   exportWlBuffer :: ClientShmManager -> ShmBufferFrame -> IO (NewObject 'Client Interface_wl_buffer)
-  exportWlBuffer client (ShmBufferFrame _ rc) = atomicallyC do
-    tryReadRc rc >>= \case
-      Nothing -> throwM (userError "ShmBufferBackend: Trying to export already disposed frame")
-      Just (Borrowed _ buffer) -> do
-        pool <- readRc buffer.pool
-        wlShmPool <- getClientShmPool client pool
-        -- NOTE no event handlers are attached here, since the caller (usually `Quasar.Wayland.Surface`) has that responsibility.
-        wlShmPool.create_buffer buffer.offset buffer.width buffer.height buffer.stride buffer.format
+  exportWlBuffer client (ShmBufferFrame (Borrowed _ buffer)) = atomicallyC do
+    pool <- readRc buffer.pool
+    wlShmPool <- getClientShmPool client pool
+    -- NOTE no event handlers are attached here, since the caller (usually `Quasar.Wayland.Surface`) has that responsibility.
+    wlShmPool.create_buffer buffer.offset buffer.width buffer.height buffer.stride buffer.format
 
   syncExportBuffer :: ShmBufferFrame -> IO ()
   syncExportBuffer _ = pure ()
 
   getExportBufferDestroyedFuture :: ShmBufferFrame -> STMc NoRetry '[] (Future '[] ())
-  getExportBufferDestroyedFuture (ShmBufferFrame _ shmBuffer) = pure $ isDisposed shmBuffer
+  getExportBufferDestroyedFuture (ShmBufferFrame (Borrowed _ externalBuffer)) = pure $ isDisposed externalBuffer
 
 data ClientShmManager = ClientShmManager {
   key :: Unique,