Issue #752: try to fix forgotten reference

src-control/Control/RefCount.hs

@@ -605,12 +605,14 @@ enableForgottenRefChecks :: IO ()
 disableForgottenRefChecks :: IO ()
 
 #ifdef NO_IGNORE_ASSERTS
-enableForgottenRefChecks =
+enableForgottenRefChecks = do
+    performMajorGCWithBlockingIfAvailable
     modifyIORef globalForgottenRef $ \case
       Disabled -> Enabled Nothing
       Enabled _  -> error "enableForgottenRefChecks: already enabled"
 
-disableForgottenRefChecks =
+disableForgottenRefChecks = do
+    performMajorGCWithBlockingIfAvailable
     modifyIORef globalForgottenRef $ \case
       Disabled -> error "disableForgottenRefChecks: already disabled"
       Enabled Nothing -> Disabled

src/Database/LSMTree.hs

@@ -272,6 +272,7 @@ import           Database.LSMTree.Internal.Unsafe (BlobRefInvalidError (..),
                      TableTrace, TableUnionNotCompatibleError (..),
                      UnionCredits (..), UnionDebt (..))
 import qualified Database.LSMTree.Internal.Unsafe as Internal
+import           GHC.Stack (HasCallStack)
 import           Prelude hiding (lookup, take, takeWhile)
 import           System.FS.API (FsPath, HasFS (..), MountPoint (..), mkFsPath)
 import           System.FS.BlockIO.API (HasBlockIO (..), defaultIOCtxParams)
@@ -1251,14 +1252,14 @@ prop> inserts table entries = traverse_ (uncurry $ insert table) entries
 -}
 {-# SPECIALISE
   inserts ::
-    (SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
+    (HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
     Table IO k v b ->
     Vector (k, v, Maybe b) ->
     IO ()
   #-}
 inserts ::
   forall m k v b.
-  (IOLike m) =>
+  (IOLike m, HasCallStack) =>
   (SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
   Table m k v b ->
   Vector (k, v, Maybe b) ->
@@ -1351,14 +1352,14 @@ prop> upserts table entries = traverse_ (uncurry $ upsert table) entries
 -}
 {-# SPECIALISE
   upserts ::
-    (SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
+    (HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
     Table IO k v b ->
     Vector (k, v) ->
     IO ()
   #-}
 upserts ::
   forall m k v b.
-  (IOLike m) =>
+  (HasCallStack, IOLike m) =>
   (SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
   Table m k v b ->
   Vector (k, v) ->
@@ -1436,14 +1437,14 @@ prop> deletes table keys = traverse_ (delete table) keys
 -}
 {-# SPECIALISE
   deletes ::
-    (SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
+    (HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
     Table IO k v b ->
     Vector k ->
     IO ()
   #-}
 deletes ::
   forall m k v b.
-  (IOLike m) =>
+  (HasCallStack, IOLike m) =>
   (SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
   Table m k v b ->
   Vector k ->
@@ -1525,14 +1526,14 @@ prop> updates table entries = traverse_ (uncurry $ update table) entries
 -}
 {-# SPECIALISE
   updates ::
-    (SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
+    (HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
     Table IO k v b ->
     Vector (k, Update v b) ->
     IO ()
   #-}
 updates ::
   forall m k v b.
-  (IOLike m) =>
+  (IOLike m, HasCallStack) =>
   (SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
   Table m k v b ->
   Vector (k, Update v b) ->
@@ -2206,14 +2207,14 @@ Throws the following exceptions:
 -}
 {-# SPECIALISE
   withCursor ::
-    (ResolveValue v) =>
+    (HasCallStack, ResolveValue v) =>
     Table IO k v b ->
     (Cursor IO k v b -> IO a) ->
     IO a
   #-}
 withCursor ::
   forall m k v b a.
-  (IOLike m) =>
+  (HasCallStack, IOLike m) =>
   (ResolveValue v) =>
   Table m k v b ->
   (Cursor m k v b -> m a) ->
@@ -2236,15 +2237,15 @@ Entry (Key 1) (Value "World")
 -}
 {-# SPECIALISE
   withCursorAtOffset ::
-    (SerialiseKey k, ResolveValue v) =>
+    (HasCallStack, SerialiseKey k, ResolveValue v) =>
     Table IO k v b ->
     k ->
     (Cursor IO k v b -> IO a) ->
     IO a
   #-}
 withCursorAtOffset ::
   forall m k v b a.
-  (IOLike m) =>
+  (HasCallStack, IOLike m) =>
   (SerialiseKey k, ResolveValue v) =>
   Table m k v b ->
   k ->
@@ -2283,13 +2284,13 @@ Throws the following exceptions:
 -}
 {-# SPECIALISE
   newCursor ::
-    (ResolveValue v) =>
+    (HasCallStack, ResolveValue v) =>
     Table IO k v b ->
     IO (Cursor IO k v b)
   #-}
 newCursor ::
   forall m k v b.
-  (IOLike m) =>
+  (HasCallStack, IOLike m) =>
   (ResolveValue v) =>
   Table m k v b ->
   m (Cursor m k v b)
@@ -2311,14 +2312,14 @@ Entry (Key 1) (Value "World")
 -}
 {-# SPECIALISE
   newCursorAtOffset ::
-    (SerialiseKey k, ResolveValue v) =>
+    (HasCallStack, SerialiseKey k, ResolveValue v) =>
     Table IO k v b ->
     k ->
     IO (Cursor IO k v b)
   #-}
 newCursorAtOffset ::
   forall m k v b.
-  (IOLike m) =>
+  (HasCallStack, IOLike m) =>
   (SerialiseKey k, ResolveValue v) =>
   Table m k v b ->
   k ->
@@ -2339,12 +2340,13 @@ All other operations on a closed cursor will throw an exception.
 -}
 {-# SPECIALISE
   closeCursor ::
+    HasCallStack =>
     Cursor IO k v b ->
     IO ()
   #-}
 closeCursor ::
   forall m k v b.
-  (IOLike m) =>
+  (HasCallStack, IOLike m) =>
   Cursor m k v b ->
   m ()
 closeCursor (Cursor cursor) =

src/Database/LSMTree/Internal/Merge.hs

@@ -44,6 +44,7 @@ import           Database.LSMTree.Internal.RunBuilder (RunBuilder, RunParams)
 import qualified Database.LSMTree.Internal.RunBuilder as Builder
 import qualified Database.LSMTree.Internal.RunReader as Reader
 import           Database.LSMTree.Internal.Serialise
+import           GHC.Stack (HasCallStack)
 import qualified System.FS.API as FS
 import           System.FS.API (HasFS)
 import           System.FS.BlockIO.API (HasBlockIO)
@@ -151,7 +152,7 @@ instance IsMergeType TreeMergeType where
       MergeUnion -> True
 
 {-# SPECIALISE new ::
-     IsMergeType t
+     (HasCallStack, IsMergeType t)
   => HasFS IO h
   -> HasBlockIO IO h
   -> Bloom.Salt
@@ -164,7 +165,7 @@ instance IsMergeType TreeMergeType where
 -- | Returns 'Nothing' if no input 'Run' contains any entries.
 -- The list of runs should be sorted from new to old.
 new ::
-     (IsMergeType t, MonadMask m, MonadSTM m, MonadST m)
+     (HasCallStack, IsMergeType t, MonadMask m, MonadSTM m, MonadST m)
   => HasFS m h
   -> HasBlockIO m h
   -> Bloom.Salt

src/Database/LSMTree/Internal/MergeSchedule.hs

@@ -83,6 +83,7 @@ import           Database.LSMTree.Internal.WriteBuffer (WriteBuffer)
 import qualified Database.LSMTree.Internal.WriteBuffer as WB
 import           Database.LSMTree.Internal.WriteBufferBlobs (WriteBufferBlobs)
 import qualified Database.LSMTree.Internal.WriteBufferBlobs as WBB
+import           GHC.Stack (HasCallStack)
 import qualified System.FS.API as FS
 import           System.FS.API (HasFS)
 import           System.FS.BlockIO.API (HasBlockIO)
@@ -198,14 +199,15 @@ data LevelsCache m h = LevelsCache_ {
   }
 
 {-# SPECIALISE mkLevelsCache ::
-     ActionRegistry IO
+     HasCallStack
+  => ActionRegistry IO
   -> Levels IO h
   -> IO (LevelsCache IO h) #-}
 -- | Flatten the argument 'Level's into a single vector of runs, including all
 -- runs that are inputs to an ongoing merge. Use that to populate the
 -- 'LevelsCache'. The cache will take a reference for each of its runs.
 mkLevelsCache ::
-     forall m h. (PrimMonad m, MonadMVar m, MonadMask m)
+     forall m h. (HasCallStack, PrimMonad m, MonadMVar m, MonadMask m)
   => ActionRegistry m
   -> Levels m h
   -> m (LevelsCache m h)
@@ -239,7 +241,8 @@ mkLevelsCache reg lvls = do
           (incoming <>) . fold <$> V.forM rs k1
 
 {-# SPECIALISE rebuildCache ::
-     ActionRegistry IO
+     HasCallStack
+  => ActionRegistry IO
   -> LevelsCache IO h
   -> Levels IO h
   -> IO (LevelsCache IO h) #-}
@@ -264,7 +267,7 @@ mkLevelsCache reg lvls = do
 -- a solution to keep blob references valid until the next /update/ comes along.
 -- Lookups should no invalidate blob erferences.
 rebuildCache ::
-     (PrimMonad m, MonadMVar m, MonadMask m)
+     (HasCallStack, PrimMonad m, MonadMVar m, MonadMask m)
   => ActionRegistry m
   -> LevelsCache m h -- ^ old cache
   -> Levels m h -- ^ new levels
@@ -274,11 +277,12 @@ rebuildCache reg oldCache newLevels = do
     mkLevelsCache reg newLevels
 
 {-# SPECIALISE duplicateLevelsCache ::
-     ActionRegistry IO
+     HasCallStack
+  => ActionRegistry IO
   -> LevelsCache IO h
   -> IO (LevelsCache IO h) #-}
 duplicateLevelsCache ::
-     (PrimMonad m, MonadMask m)
+     (HasCallStack, PrimMonad m, MonadMask m)
   => ActionRegistry m
   -> LevelsCache m h
   -> m (LevelsCache m h)
@@ -288,11 +292,12 @@ duplicateLevelsCache reg cache = do
     pure cache { cachedRuns = rs' }
 
 {-# SPECIALISE releaseLevelsCache ::
-     ActionRegistry IO
+     HasCallStack
+  => ActionRegistry IO
   -> LevelsCache IO h
   -> IO () #-}
 releaseLevelsCache ::
-     (PrimMonad m, MonadMask m)
+     (HasCallStack, PrimMonad m, MonadMask m)
   => ActionRegistry m
   -> LevelsCache m h
   -> m ()
@@ -440,7 +445,8 @@ releaseUnionCache reg (UnionCache mt) =
 -------------------------------------------------------------------------------}
 
 {-# SPECIALISE updatesWithInterleavedFlushes ::
-     Tracer IO (AtLevel MergeTrace)
+     HasCallStack
+  => Tracer IO (AtLevel MergeTrace)
   -> TableConfig
   -> ResolveSerialisedValue
   -> HasFS IO h
@@ -478,7 +484,7 @@ releaseUnionCache reg (UnionCache mt) =
 -- whole run should then end up in a fresh write buffer.
 updatesWithInterleavedFlushes ::
      forall m h.
-     (MonadMask m, MonadMVar m, MonadSTM m, MonadST m)
+     (HasCallStack, MonadMask m, MonadMVar m, MonadSTM m, MonadST m)
   => Tracer m (AtLevel MergeTrace)
   -> TableConfig
   -> ResolveSerialisedValue
@@ -560,7 +566,8 @@ addWriteBufferEntries hfs f wbblobs maxn =
 
 
 {-# SPECIALISE flushWriteBuffer ::
-     Tracer IO (AtLevel MergeTrace)
+     HasCallStack
+  => Tracer IO (AtLevel MergeTrace)
   -> TableConfig
   -> ResolveSerialisedValue
   -> HasFS IO h
@@ -576,7 +583,7 @@ addWriteBufferEntries hfs f wbblobs maxn =
 -- The returned table content contains an updated set of levels, where the write
 -- buffer is inserted into level 1.
 flushWriteBuffer ::
-     (MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
+     (HasCallStack, MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
   => Tracer m (AtLevel MergeTrace)
   -> TableConfig
   -> ResolveSerialisedValue

src/Database/LSMTree/Internal/MergingRun.hs

@@ -268,9 +268,11 @@
 -- @withRollback reg (duplicateRuns mr) (mapM_ releaseRef)@ isn't exception-safe
 -- since if one of the @releaseRef@ calls fails, the following ones aren't run.
 {-# SPECIALISE duplicateRuns ::
-     Ref (MergingRun t IO h) -> IO (V.Vector (Ref (Run IO h))) #-}
+     HasCallStack
+  => Ref (MergingRun t IO h)
+  -> IO (V.Vector (Ref (Run IO h))) #-}
 duplicateRuns ::
-     (PrimMonad m, MonadMVar m, MonadMask m)
+     (HasCallStack, PrimMonad m, MonadMVar m, MonadMask m)
   => Ref (MergingRun t m h)
   -> m (V.Vector (Ref (Run m h)))
 duplicateRuns (DeRef mr) =

src/Database/LSMTree/Internal/Readers.hs

@@ -43,6 +43,7 @@ import qualified Database.LSMTree.Internal.RunReader as RunReader
 import           Database.LSMTree.Internal.Serialise
 import qualified Database.LSMTree.Internal.WriteBuffer as WB
 import qualified Database.LSMTree.Internal.WriteBufferBlobs as WB
+import           GHC.Stack (HasCallStack)
 import qualified KMerge.Heap as Heap
 import qualified System.FS.API as FS
 
@@ -148,12 +149,13 @@ data ReaderSource m h =
   | FromReaders     !ReadersMergeType ![ReaderSource m h]
 
 {-# SPECIALISE new ::
-     ResolveSerialisedValue
+     HasCallStack
+  => ResolveSerialisedValue
   -> OffsetKey
   -> [ReaderSource IO h]
   -> IO (Maybe (Readers IO h)) #-}
 new :: forall m h.
-     (MonadMask m, MonadST m, MonadSTM m)
+     (HasCallStack, MonadMask m, MonadST m, MonadSTM m)
   => ResolveSerialisedValue
   -> OffsetKey
   -> [ReaderSource m h]

src/Database/LSMTree/Internal/RunReader.hs

@@ -49,6 +49,7 @@ import           Database.LSMTree.Internal.RawOverflowPage (RawOverflowPage,
 import           Database.LSMTree.Internal.RawPage
 import qualified Database.LSMTree.Internal.Run as Run
 import           Database.LSMTree.Internal.Serialise
+import           GHC.Stack (HasCallStack)
 import qualified System.FS.API as FS
 import           System.FS.API (HasFS)
 import qualified System.FS.BlockIO.API as FS
@@ -93,11 +94,12 @@ data OffsetKey = NoOffsetKey | OffsetKey !SerialisedKey
   deriving stock Show
 
 {-# SPECIALISE new ::
-     OffsetKey
+     HasCallStack
+  => OffsetKey
   -> Ref (Run.Run IO h)
   -> IO (RunReader IO h) #-}
 new :: forall m h.
-     (MonadMask m, MonadSTM m, PrimMonad m)
+     (HasCallStack, MonadMask m, MonadSTM m, PrimMonad m)
   => OffsetKey
   -> Ref (Run.Run m h)
   -> m  (RunReader m h)