diff --git a/quasar/src/Quasar/Resources/TRcVar.hs b/quasar/src/Quasar/Resources/TRcVar.hs index c02b062..f90272b 100644 --- a/quasar/src/Quasar/Resources/TRcVar.hs +++ b/quasar/src/Quasar/Resources/TRcVar.hs @@ -1,7 +1,15 @@ module Quasar.Resources.TRcVar ( + RcVar, + newRcVar, + newRcVarIO, + tryReadRcVar, + tryDuplicateRcVar, + TRcVar, newTRcVar, newTRcVarIO, + newFnRcVar, + newFnRcVarIO, tryReadTRcVar, tryDuplicateTRcVar, ) where @@ -9,6 +17,7 @@ module Quasar.Resources.TRcVar ( import Quasar.Prelude import Quasar.Resources import Quasar.Resources.DisposableVar +import Quasar.Exceptions (ExceptionSink) -- | A TRcVar is a disposable storage (like a `TDisposableVar`) that can be -- cloned. Every copy has an independent lifetime. @@ -65,3 +74,70 @@ tryDuplicateTRcVar (TRcVar var) = liftSTMc @NoRetry @'[] do modifyTVar rc.lockCount succ TRcVar <$> newTDisposableVar rc decrementTRcVar + + +-- | A RcVar is a disposable storage (like a `DisposableVar`) that can be +-- cloned. Every copy has an independent lifetime. +newtype RcVar a = RcVar (DisposableVar (RcVarRc a)) + deriving Disposable + +data RcVarRc a = RcVarRc { + -- Refcount that tracks how many locks exists in this group of locks. + lockCount :: TVar Word64, + -- A release function. Called when the last lock of the group is disposed. + cleanup :: a -> STMc NoRetry '[] Disposer, + content :: a +} + +decrementRcVar :: RcVarRc a -> STMc NoRetry '[] Disposer +decrementRcVar rc = do + let lockCount = rc.lockCount + c <- readTVar lockCount + writeTVar rc.lockCount (pred c) + if c == 0 + then rc.cleanup rc.content + else pure mempty + +newRcVar :: MonadSTMc NoRetry '[] m => (a -> STMc NoRetry '[] Disposer) -> a -> m (RcVar a) +newRcVar cleanup content = liftSTMc @NoRetry @'[] do + lockCount <- newTVar 1 + let rc = RcVarRc { + lockCount, + cleanup, + content + } + RcVar <$> newDisposableVar decrementRcVar rc + +newFnRcVar :: MonadSTMc NoRetry '[] m => ExceptionSink -> (a -> IO ()) -> a -> m (RcVar a) +newFnRcVar sink cleanup = liftSTMc @NoRetry @'[] . + newRcVar \value -> newUnmanagedIODisposer (cleanup value) sink + +newRcVarIO :: MonadIO m => (a -> STMc NoRetry '[] Disposer) -> a -> m (RcVar a) +newRcVarIO cleanup content = liftIO do + lockCount <- newTVarIO 1 + let rc = RcVarRc { + lockCount, + cleanup, + content + } + RcVar <$> newDisposableVarIO decrementRcVar rc + +newFnRcVarIO :: MonadIO m => ExceptionSink -> (a -> IO ()) -> a -> m (RcVar a) +newFnRcVarIO sink cleanup = liftIO . + newRcVarIO \value -> newUnmanagedIODisposer (cleanup value) sink + +-- | Read the content of the lock, if the lock has not been disposed. +tryReadRcVar :: MonadSTMc NoRetry '[] m => RcVar a -> m (Maybe a) +tryReadRcVar (RcVar var) = liftSTMc @NoRetry @'[] do + (.content) <<$>> tryReadDisposableVar var + +-- | Produces a _new_ lock that points to the same content, but has an +-- independent lifetime. The caller has to ensure the new lock is disposed. +-- +-- Usually this would be used to pass a copy of the lock to another component. +tryDuplicateRcVar :: MonadSTMc NoRetry '[] m => RcVar a -> m (Maybe (RcVar a)) +tryDuplicateRcVar (RcVar var) = liftSTMc @NoRetry @'[] do + tryReadDisposableVar var >>= mapM \rc -> do + modifyTVar rc.lockCount succ + RcVar <$> newDisposableVar decrementRcVar rc +