diff --git a/src-control/Control/RefCount.hs b/src-control/Control/RefCount.hs index bfd032ee1..e033dc80a 100644 --- a/src-control/Control/RefCount.hs +++ b/src-control/Control/RefCount.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} module Control.RefCount ( -- * Using references @@ -30,15 +31,12 @@ module Control.RefCount ( , checkForgottenRefs ) where -import Data.Kind (Type) -import Data.Primitive.PrimVar - import Control.DeepSeq import Control.Exception (assert) import Control.Monad (when) import Control.Monad.Class.MonadThrow import Control.Monad.Primitive - +import Data.Primitive.PrimVar import GHC.Stack (CallStack, prettyCallStack) #ifdef NO_IGNORE_ASSERTS @@ -195,9 +193,8 @@ instance NFData obj => NFData (Ref obj) where -- For objects in this class the guarantee is that (when the 'Ref' rules are -- followed) the object's finaliser is called exactly once. -- -class RefCounted obj where - type FinaliserM obj :: Type -> Type - getRefCounter :: obj -> RefCounter (FinaliserM obj) +class RefCounted m obj | obj -> m where + getRefCounter :: obj -> RefCounter m #ifdef NO_IGNORE_ASSERTS #define HasCallStackIfDebug HasCallStack @@ -205,20 +202,27 @@ class RefCounted obj where #define HasCallStackIfDebug () #endif --- GHC says specialising is too complicated! But it's ok, each of these can --- inline to calling a few other specialised helpers. -{-# INLINE newRef #-} -{-# INLINE releaseRef #-} -{-# INLINE dupRef #-} -{-# INLINE deRefWeak #-} - +{-# SPECIALISE + newRef :: + RefCounted IO obj + => IO () + -> (RefCounter IO -> obj) + -> IO (Ref obj) + #-} -- | Make a new reference. -- -- The given finaliser is run when the last reference is released. The -- finaliser is run with async exceptions masked. -- +{-# SPECIALISE + newRef :: + RefCounted IO obj + => IO () + -> (RefCounter IO -> obj) + -> IO (Ref obj) + #-} newRef :: - (RefCounted obj, FinaliserM obj ~ m, PrimMonad m) + (RefCounted m obj, PrimMonad m) => HasCallStackIfDebug => m () -> (RefCounter m -> obj) @@ -232,8 +236,14 @@ newRef finaliser mkObject = do -- | Release a reference to an object that will no longer be used (via this -- reference). -- +{-# SPECIALISE + releaseRef :: + RefCounted IO obj + => Ref obj + -> IO () + #-} releaseRef :: - (RefCounted obj, FinaliserM obj ~ m, PrimMonad m, MonadMask m) + (RefCounted m obj, PrimMonad m, MonadMask m) => HasCallStackIfDebug => Ref obj -> m () @@ -261,6 +271,12 @@ deRef ref@Ref{refobj} = `seq` refobj #endif +{-# SPECIALISE + withRef :: + Ref obj + -> (obj -> IO a) + -> IO a + #-} {-# INLINE withRef #-} -- | Use the object in a 'Ref'. Do not retain the object after the scope of -- the body. If you cannot use scoped \"with\" style, use pattern 'DeRef'. @@ -276,10 +292,16 @@ withRef ref@Ref{refobj} f = do assertNoUseAfterRelease ref f refobj +{-# SPECIALISE + dupRef :: + RefCounted IO obj + => Ref obj + -> IO (Ref obj) + #-} -- | Duplicate an existing reference, to produce a new reference. -- dupRef :: - (RefCounted obj, FinaliserM obj ~ m, PrimMonad m) + (RefCounted m obj, PrimMonad m) => HasCallStackIfDebug => Ref obj -> m (Ref obj) @@ -308,11 +330,17 @@ mkWeakRef Ref {refobj} = WeakRef refobj mkWeakRefFromRaw :: obj -> WeakRef obj mkWeakRefFromRaw obj = WeakRef obj +{-# SPECIALISE + deRefWeak :: + RefCounted IO obj + => WeakRef obj + -> IO (Maybe (Ref obj)) + #-} -- | If the object is still alive, obtain a /new/ normal reference. The normal -- rules for 'Ref' apply, including the need to eventually call 'releaseRef'. -- deRefWeak :: - (RefCounted obj, FinaliserM obj ~ m, PrimMonad m) + (RefCounted m obj, PrimMonad m) => HasCallStackIfDebug => WeakRef obj -> m (Maybe (Ref obj)) diff --git a/src/Database/LSMTree/Internal/BlobFile.hs b/src/Database/LSMTree/Internal/BlobFile.hs index 2ccccf599..24c93d40b 100644 --- a/src/Database/LSMTree/Internal/BlobFile.hs +++ b/src/Database/LSMTree/Internal/BlobFile.hs @@ -32,8 +32,7 @@ data BlobFile m h = BlobFile { } deriving stock (Show) -instance RefCounted (BlobFile m h) where - type FinaliserM (BlobFile m h) = m +instance RefCounted m (BlobFile m h) where getRefCounter = blobFileRefCounter instance NFData h => NFData (BlobFile m h) where diff --git a/src/Database/LSMTree/Internal/MergeSchedule.hs b/src/Database/LSMTree/Internal/MergeSchedule.hs index dfe414c2d..e8d14e975 100644 --- a/src/Database/LSMTree/Internal/MergeSchedule.hs +++ b/src/Database/LSMTree/Internal/MergeSchedule.hs @@ -325,8 +325,7 @@ data MergingRun m h = MergingRun { , mergeRefCounter :: !(RefCounter m) } -instance RefCounted (MergingRun m h) where - type FinaliserM (MergingRun m h) = m +instance RefCounted m (MergingRun m h) where getRefCounter = mergeRefCounter {-# SPECIALISE newMergingRun :: diff --git a/src/Database/LSMTree/Internal/Run.hs b/src/Database/LSMTree/Internal/Run.hs index c066ab4bc..798c54696 100644 --- a/src/Database/LSMTree/Internal/Run.hs +++ b/src/Database/LSMTree/Internal/Run.hs @@ -101,8 +101,7 @@ instance NFData h => NFData (Run m h) where rnf a `seq` rwhnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f `seq` rnf g `seq` rnf h `seq` rwhnf i `seq` rwhnf j -instance RefCounted (Run m h) where - type FinaliserM (Run m h) = m +instance RefCounted m (Run m h) where getRefCounter = runRefCounter size :: Ref (Run m h) -> NumEntries diff --git a/src/Database/LSMTree/Internal/WriteBufferBlobs.hs b/src/Database/LSMTree/Internal/WriteBufferBlobs.hs index d97802038..880c44151 100644 --- a/src/Database/LSMTree/Internal/WriteBufferBlobs.hs +++ b/src/Database/LSMTree/Internal/WriteBufferBlobs.hs @@ -112,8 +112,7 @@ data WriteBufferBlobs m h = instance NFData h => NFData (WriteBufferBlobs m h) where rnf (WriteBufferBlobs a b c) = rnf a `seq` rnf b `seq` rnf c -instance RefCounted (WriteBufferBlobs m h) where - type FinaliserM (WriteBufferBlobs m h) = m +instance RefCounted m (WriteBufferBlobs m h) where getRefCounter = writeBufRefCounter {-# SPECIALISE new :: HasFS IO h -> FS.FsPath -> IO (Ref (WriteBufferBlobs IO h)) #-} diff --git a/test-control/Test/Control/RefCount.hs b/test-control/Test/Control/RefCount.hs index 5362eeff3..b2e7e6aaf 100644 --- a/test-control/Test/Control/RefCount.hs +++ b/test-control/Test/Control/RefCount.hs @@ -108,14 +108,12 @@ readRefCount (RefCounter countVar _) = readPrimVar countVar #ifdef NO_IGNORE_ASSERTS data TestObject = TestObject !(RefCounter IO) -instance RefCounted TestObject where - type FinaliserM TestObject = IO +instance RefCounted IO TestObject where getRefCounter (TestObject rc) = rc data TestObject2 = TestObject2 (Ref TestObject) -instance RefCounted TestObject2 where - type FinaliserM TestObject2 = IO +instance RefCounted IO TestObject2 where getRefCounter (TestObject2 (DeRef to1)) = getRefCounter to1 prop_ref_double_free :: Property