From bc022455692e5196338b0d88244cf004863ac200 Mon Sep 17 00:00:00 2001
From: Joris Dral <joris@well-typed.com>
Date: Tue, 1 Jul 2025 15:12:33 +0200
Subject: [PATCH 1/3] Issue #752: try to fix forgotten reference

Since I can't reproduce the bug but it has popped up twice now, I've tried to
fix the test by making sure that we use `bracket`s everywhere. Hopefully that is
the fix.
---
 test/Test/Database/LSMTree/UnitTests.hs | 31 +++++++++++--------------
 1 file changed, 13 insertions(+), 18 deletions(-)

diff --git a/test/Test/Database/LSMTree/UnitTests.hs b/test/Test/Database/LSMTree/UnitTests.hs
index bd2397322..e1d2c0db2 100644
--- a/test/Test/Database/LSMTree/UnitTests.hs
+++ b/test/Test/Database/LSMTree/UnitTests.hs
@@ -3,6 +3,8 @@
 
 module Test.Database.LSMTree.UnitTests (tests) where
 
+import           Control.Exception (Exception, bracket, try)
+import           Control.Monad (void)
 import           Control.Tracer (nullTracer)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS
@@ -11,13 +13,10 @@ import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map as Map
 import qualified Data.Vector as V
 import           Data.Word
-import qualified System.FS.API as FS
-
 import           Database.LSMTree as R
-
-import           Control.Exception (Exception, bracket, try)
 import           Database.LSMTree.Extras.Generators ()
 import           Database.LSMTree.Internal.Serialise (SerialisedKey)
+import qualified System.FS.API as FS
 import qualified Test.QuickCheck.Arbitrary as QC
 import qualified Test.QuickCheck.Gen as QC
 import           Test.Tasty (TestTree, testGroup)
@@ -222,24 +221,20 @@ unit_union_credit_0 =
 unit_union_blobref_invalidation :: Assertion
 unit_union_blobref_invalidation =
     withTempIOHasBlockIO "test" $ \hfs hbio ->
-    withOpenSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \sess -> do
-      t1 <- newTableWith @_ @Key1 @Value1 @Blob1 config sess
+    withOpenSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \sess ->
+    withTableWith config sess $ \t1 -> do
       for_ ([0..99] :: [Word64]) $ \i ->
         inserts t1 [(Key1 i, Value1 i, Just (Blob1 i))]
-      t2 <- t1 `union` t1
-
-      -- do lookups on the union table (the result contains blob refs)
-      res <- lookups t2 (Key1 <$> [0..99])
+      withUnion t1 t1 $ \t2 -> do
+        -- do lookups on the union table (the result contains blob refs)
+        res <- lookups t2 (Key1 <$> [0..99])
 
-      -- progress original table (supplying merge credits would be most direct),
-      -- so merges complete
-      inserts t1 (fmap (\i -> (Key1 i, Value1 i, Nothing)) [1000..2000])
-      -- closeTable it, so it doesn't hold open extra references
-      closeTable t1
+        -- progress original table (supplying merge credits would be most direct),
+        -- so merges complete
+        inserts t1 (fmap (\i -> (Key1 i, Value1 i, Nothing)) [1000..2000])
 
-      -- try to resolve the blob refs we obtained earlier
-      _blobs <- retrieveBlobs sess (V.mapMaybe R.getBlob res)
-      pure ()
+        -- try to resolve the blob refs we obtained earlier
+        void $ retrieveBlobs sess (V.mapMaybe R.getBlob res)
   where
     config = defaultTableConfig {
         confWriteBufferAlloc = AllocNumEntries 4

From 6c74dd207e58d74d50f15b450e878b8a08119cd6 Mon Sep 17 00:00:00 2001
From: Joris Dral <joris@well-typed.com>
Date: Tue, 1 Jul 2025 17:39:08 +0200
Subject: [PATCH 2/3] Callstacks

---
 src/Database/LSMTree.hs                       | 36 ++++++++++---------
 src/Database/LSMTree/Internal/Merge.hs        |  5 +--
 .../LSMTree/Internal/MergeSchedule.hs         | 31 +++++++++-------
 src/Database/LSMTree/Internal/MergingRun.hs   |  6 ++--
 src/Database/LSMTree/Internal/Readers.hs      |  6 ++--
 src/Database/LSMTree/Internal/RunReader.hs    |  6 ++--
 src/Database/LSMTree/Internal/Unsafe.hs       | 20 ++++++-----
 test/Database/LSMTree/Class.hs                | 19 ++++++----
 test/Test/Database/LSMTree/UnitTests.hs       |  4 +--
 9 files changed, 80 insertions(+), 53 deletions(-)

diff --git a/src/Database/LSMTree.hs b/src/Database/LSMTree.hs
index 2c685a0ac..5625ec513 100644
--- a/src/Database/LSMTree.hs
+++ b/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,7 +2237,7 @@ 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) ->
@@ -2244,7 +2245,7 @@ Entry (Key 1) (Value "World")
   #-}
 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) =
diff --git a/src/Database/LSMTree/Internal/Merge.hs b/src/Database/LSMTree/Internal/Merge.hs
index edf51d491..dc4f0ee94 100644
--- a/src/Database/LSMTree/Internal/Merge.hs
+++ b/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
diff --git a/src/Database/LSMTree/Internal/MergeSchedule.hs b/src/Database/LSMTree/Internal/MergeSchedule.hs
index aae9247da..aa312d842 100644
--- a/src/Database/LSMTree/Internal/MergeSchedule.hs
+++ b/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
diff --git a/src/Database/LSMTree/Internal/MergingRun.hs b/src/Database/LSMTree/Internal/MergingRun.hs
index 71000fba7..7d57efb99 100644
--- a/src/Database/LSMTree/Internal/MergingRun.hs
+++ b/src/Database/LSMTree/Internal/MergingRun.hs
@@ -268,9 +268,11 @@ unsafeNew mergeDebt (SpentCredits spentCredits)
 -- @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) =
diff --git a/src/Database/LSMTree/Internal/Readers.hs b/src/Database/LSMTree/Internal/Readers.hs
index d7fae0caa..ef39095e4 100644
--- a/src/Database/LSMTree/Internal/Readers.hs
+++ b/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]
diff --git a/src/Database/LSMTree/Internal/RunReader.hs b/src/Database/LSMTree/Internal/RunReader.hs
index 0dfa97190..af7a357ad 100644
--- a/src/Database/LSMTree/Internal/RunReader.hs
+++ b/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)
diff --git a/src/Database/LSMTree/Internal/Unsafe.hs b/src/Database/LSMTree/Internal/Unsafe.hs
index 588b4a247..ce8ab7de1 100644
--- a/src/Database/LSMTree/Internal/Unsafe.hs
+++ b/src/Database/LSMTree/Internal/Unsafe.hs
@@ -153,6 +153,7 @@ import           Database.LSMTree.Internal.UniqCounter
 import qualified Database.LSMTree.Internal.Vector as V
 import qualified Database.LSMTree.Internal.WriteBuffer as WB
 import qualified Database.LSMTree.Internal.WriteBufferBlobs as WBB
+import           GHC.Stack (HasCallStack)
 import qualified System.FS.API as FS
 import           System.FS.API (FsError, FsErrorPath (..), FsPath, HasFS)
 import qualified System.FS.API.Lazy as FS
@@ -1242,7 +1243,8 @@ rangeLookup resolve range t fromEntry = do
         else pure (V.concat (reverse (V.slice 0 n chunk : chunks)))
 
 {-# SPECIALISE updates ::
-     ResolveSerialisedValue
+     HasCallStack
+  => ResolveSerialisedValue
   -> V.Vector (SerialisedKey, Entry SerialisedValue SerialisedBlob)
   -> Table IO h
   -> IO () #-}
@@ -1250,7 +1252,7 @@ rangeLookup resolve range t fromEntry = do
 --
 -- Does not enforce that upsert and BLOBs should not occur in the same table.
 updates ::
-     (MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
+     (HasCallStack, MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
   => ResolveSerialisedValue
   -> V.Vector (SerialisedKey, Entry SerialisedValue SerialisedBlob)
   -> Table m h
@@ -1393,14 +1395,15 @@ data CursorEnv m h = CursorEnv {
   }
 
 {-# SPECIALISE withCursor ::
-     ResolveSerialisedValue
+     HasCallStack
+  => ResolveSerialisedValue
   -> OffsetKey
   -> Table IO h
   -> (Cursor IO h -> IO a)
   -> IO a #-}
 -- | See 'Database.LSMTree.withCursor'.
 withCursor ::
-     (MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
+     (HasCallStack, MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
   => ResolveSerialisedValue
   -> OffsetKey
   -> Table m h
@@ -1409,13 +1412,14 @@ withCursor ::
 withCursor resolve offsetKey t = bracket (newCursor resolve offsetKey t) closeCursor
 
 {-# SPECIALISE newCursor ::
-     ResolveSerialisedValue
+     HasCallStack
+  => ResolveSerialisedValue
   -> OffsetKey
   -> Table IO h
   -> IO (Cursor IO h) #-}
 -- | See 'Database.LSMTree.newCursor'.
 newCursor ::
-     (MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
+     (HasCallStack, MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
   => ResolveSerialisedValue
   -> OffsetKey
   -> Table m h
@@ -1495,10 +1499,10 @@ lookupTreeToReaderSource = \case
       MR.MergeUnion -> Readers.MergeUnion
       MR.MergeLevel -> Readers.MergeLevel
 
-{-# SPECIALISE closeCursor :: Cursor IO h -> IO () #-}
+{-# SPECIALISE closeCursor :: HasCallStack => Cursor IO h -> IO () #-}
 -- | See 'Database.LSMTree.closeCursor'.
 closeCursor ::
-     (MonadMask m, MonadMVar m, MonadSTM m, PrimMonad m)
+     (HasCallStack, MonadMask m, MonadMVar m, MonadSTM m, PrimMonad m)
   => Cursor m h
   -> m ()
 closeCursor Cursor {..} = do
diff --git a/test/Database/LSMTree/Class.hs b/test/Database/LSMTree/Class.hs
index d4e4bc39c..f3c30ae94 100644
--- a/test/Database/LSMTree/Class.hs
+++ b/test/Database/LSMTree/Class.hs
@@ -28,6 +28,7 @@ import qualified Database.LSMTree.Internal.Paths as RIP
 import qualified Database.LSMTree.Internal.Types as RT (Table (..))
 import qualified Database.LSMTree.Internal.Unsafe as RU (SessionEnv (..),
                      Table (..), withKeepSessionOpen)
+import           GHC.Stack (HasCallStack)
 import           Test.Util.FS (flipRandomBitInRandomFileHardlinkSafe)
 import           Test.Util.QC (Choice)
 
@@ -72,7 +73,8 @@ class (IsSession (Session h)) => IsTable h where
         -> m (V.Vector (Entry k v (BlobRef h m b)))
 
     newCursor ::
-           ( IOLike m
+           ( HasCallStack
+           , IOLike m
            , C k v b
            )
         => Maybe k
@@ -80,7 +82,8 @@ class (IsSession (Session h)) => IsTable h where
         -> m (Cursor h m k v b)
 
     closeCursor ::
-           ( IOLike m
+           ( HasCallStack
+           , IOLike m
            , C k v b
            )
         => proxy h
@@ -106,7 +109,8 @@ class (IsSession (Session h)) => IsTable h where
         -> m (V.Vector b)
 
     updates ::
-           ( IOLike m
+           ( HasCallStack
+           , IOLike m
            , C k v b
            )
         => h m k v b
@@ -114,7 +118,8 @@ class (IsSession (Session h)) => IsTable h where
         -> m ()
 
     inserts ::
-           ( IOLike m
+           ( HasCallStack
+           , IOLike m
            , C k v b
            )
         => h m k v b
@@ -122,7 +127,8 @@ class (IsSession (Session h)) => IsTable h where
         -> m ()
 
     deletes ::
-           ( IOLike m
+           ( HasCallStack
+           , IOLike m
            , C k v b
            )
         => h m k v b
@@ -130,7 +136,8 @@ class (IsSession (Session h)) => IsTable h where
         -> m ()
 
     upserts ::
-           ( IOLike m
+           ( HasCallStack
+           , IOLike m
            , C k v b
            )
         => h m k v b
diff --git a/test/Test/Database/LSMTree/UnitTests.hs b/test/Test/Database/LSMTree/UnitTests.hs
index e1d2c0db2..d0671634d 100644
--- a/test/Test/Database/LSMTree/UnitTests.hs
+++ b/test/Test/Database/LSMTree/UnitTests.hs
@@ -4,7 +4,7 @@
 module Test.Database.LSMTree.UnitTests (tests) where
 
 import           Control.Exception (Exception, bracket, try)
-import           Control.Monad (void)
+import           Control.Monad (forM_, void)
 import           Control.Tracer (nullTracer)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS
@@ -219,7 +219,7 @@ unit_union_credit_0 =
 -- | Blob refs into a union don't get invalidated when updating the union's
 -- input tables.
 unit_union_blobref_invalidation :: Assertion
-unit_union_blobref_invalidation =
+unit_union_blobref_invalidation = forM_ @[] @IO @Int [1..100] $ \_ ->
     withTempIOHasBlockIO "test" $ \hfs hbio ->
     withOpenSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \sess ->
     withTableWith config sess $ \t1 -> do

From 0ae323988605834f5d13f6a766f050e1f2ea9247 Mon Sep 17 00:00:00 2001
From: Joris Dral <joris@well-typed.com>
Date: Mon, 7 Jul 2025 14:24:38 +0200
Subject: [PATCH 3/3] WIP: GC

---
 src-control/Control/RefCount.hs | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/src-control/Control/RefCount.hs b/src-control/Control/RefCount.hs
index f123ba7c4..1b91757f9 100644
--- a/src-control/Control/RefCount.hs
+++ b/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