Repository: IntersectMBO/lsm-tree
Pull request #670: Cache lookup tree for the union level
Author: login: mheinzel
Created: 2025-04-07T13:04:01Z | Merged: 2025-04-08T12:45:38Z

This avoids having to rebuild it and most importantly keeps blob references from becoming invalidated.




Diff:
diff --git a/src-extras/Database/LSMTree/Extras/NoThunks.hs b/src-extras/Database/LSMTree/Extras/NoThunks.hs
index e7a456c9e..7d58439fd 100644
--- a/src-extras/Database/LSMTree/Extras/NoThunks.hs
+++ b/src-extras/Database/LSMTree/Extras/NoThunks.hs
@@ -52,6 +52,7 @@ import qualified Database.LSMTree.Internal.Merge as Merge
 import           Database.LSMTree.Internal.MergeSchedule
 import           Database.LSMTree.Internal.MergingRun
 import           Database.LSMTree.Internal.MergingTree
+import           Database.LSMTree.Internal.MergingTree.Lookup (LookupTree (..))
 import           Database.LSMTree.Internal.Page
 import           Database.LSMTree.Internal.PageAcc
 import           Database.LSMTree.Internal.Paths
@@ -338,6 +339,11 @@ deriving anyclass instance
   , NoThunks (StrictMVar m (MergingTreeState m h))
   ) => NoThunks (UnionLevel m h)
 
+deriving stock instance Generic (UnionCache m h)
+deriving anyclass instance
+  ( Typeable m, Typeable (PrimState m), Typeable h
+  ) => NoThunks (UnionCache m h)
+
 deriving stock instance Generic MergePolicyForLevel
 deriving anyclass instance NoThunks MergePolicyForLevel
 
@@ -404,6 +410,9 @@ deriving anyclass instance
   , NoThunks (StrictMVar m (MergingRunState LevelMergeType m h))
   ) => NoThunks (PreExistingRun m h)
 
+deriving stock instance Generic (LookupTree a)
+deriving anyclass instance NoThunks a => NoThunks (LookupTree a)
+
 {-------------------------------------------------------------------------------
   Entry
 -------------------------------------------------------------------------------}
diff --git a/src/Database/LSMTree/Internal.hs b/src/Database/LSMTree/Internal.hs
index 607e1ea9e..4f5e9b1ee 100644
--- a/src/Database/LSMTree/Internal.hs
+++ b/src/Database/LSMTree/Internal.hs
@@ -805,53 +805,48 @@ lookups ::
 lookups resolve ks t = do
     traceWith (tableTracer t) $ TraceLookups (V.length ks)
     withOpenTable t $ \tEnv ->
-      RW.withReadAccess (tableContent tEnv) $ \tableContent -> do
-        case tableUnionLevel tableContent of
-          NoUnion -> regularLevelLookups tEnv tableContent
-          Union tree -> do
+      RW.withReadAccess (tableContent tEnv) $ \tc -> do
+        case tableUnionLevel tc of
+          NoUnion -> lookupsRegular tEnv tc
+          Union tree unionCache -> do
             isStructurallyEmpty tree >>= \case
-              True  -> regularLevelLookups tEnv tableContent
-              False ->
-                -- TODO: the blob refs returned from the tree can be invalidated
-                -- by supplyUnionCredits or other operations on any table that
-                -- shares merging runs or trees. We need to keep open the runs!
-                -- This could be achieved by storing the LookupTree and only
-                -- calling MT.releaseLookupTree later, when we are okay with
-                -- invalidating the blob refs (similar to the LevelsCache).
-                -- Lookups then use the cached tree, but when should we rebuild
-                -- the tree? On each call to supplyUnionCredits?
-                withActionRegistry $ \reg -> do
-                  regularResult <-
-                    -- asynchronously, so tree lookup batches can already be
-                    -- submitted without waiting for the result.
-                    Async.async $ regularLevelLookups tEnv tableContent
-                  treeBatches <- MT.buildLookupTree reg tree
-                  treeResults <- forM treeBatches $ \runs ->
-                    Async.async $ treeBatchLookups tEnv runs
-                  -- TODO: if regular levels are empty, don't add them to tree
-                  res <- MT.foldLookupTree resolve $
-                    MT.mkLookupNode MR.MergeLevel $ V.fromList
-                      [ MT.LookupBatch regularResult
-                      , treeResults
-                      ]
-                  MT.releaseLookupTree reg treeBatches
-                  return res
+              True  -> lookupsRegular tEnv tc
+              False -> if WB.null (tableWriteBuffer tc) && V.null (tableLevels tc)
+                         then lookupsUnion tEnv unionCache
+                         else lookupsRegularAndUnion tEnv tc unionCache
   where
-    regularLevelLookups tEnv tableContent = do
-        let !cache = tableCache tableContent
+    lookupsRegular tEnv tc = do
+        let !cache = tableCache tc
         lookupsIOWithWriteBuffer
           (tableHasBlockIO tEnv)
           (tableArenaManager t)
           resolve
-          (tableWriteBuffer tableContent)
-          (tableWriteBufferBlobs tableContent)
+          (tableWriteBuffer tc)
+          (tableWriteBufferBlobs tc)
           (cachedRuns cache)
           (cachedFilters cache)
           (cachedIndexes cache)
           (cachedKOpsFiles cache)
           ks
 
-    treeBatchLookups tEnv runs =
+    lookupsUnion tEnv unionCache = do
+        treeResults <- flip MT.mapMStrict (cachedTree unionCache) $ \runs ->
+          Async.async $ lookupsUnionSingleBatch tEnv runs
+        MT.foldLookupTree resolve treeResults
+
+    lookupsRegularAndUnion tEnv tc unionCache = do
+        -- asynchronously, so tree lookup batches can already be submitted
+        -- without waiting for the regular level result.
+        regularResult <- Async.async $ lookupsRegular tEnv tc
+        treeResults <- flip MT.mapMStrict (cachedTree unionCache) $ \runs ->
+          Async.async $ lookupsUnionSingleBatch tEnv runs
+        MT.foldLookupTree resolve $
+          MT.mkLookupNode MR.MergeLevel $ V.fromList
+            [ MT.LookupBatch regularResult
+            , treeResults
+            ]
+
+    lookupsUnionSingleBatch tEnv runs =
         lookupsIO
           (tableHasBlockIO tEnv)
           (tableArenaManager t)
@@ -1264,7 +1259,7 @@ createSnapshot snap label tableType t = do
         -- If a merging tree exists, do the same hard-linking for the runs within
         mTreeOpt <- case tableUnionLevel content of
           NoUnion -> pure Nothing
-          Union mTreeRef -> do
+          Union mTreeRef _cache -> do
             mTree <- toSnapMergingTree mTreeRef
             Just <$> traverse (snapshotRun hfs hbio snapUc reg snapDir) mTree
 
@@ -1380,8 +1375,13 @@ openSnapshot sesh policyOveride label tableType snap resolve =
               Just mTree -> do
                 snapTree <- traverse (openRun hfs hbio uc reg snapDir activeDir) mTree
                 mt <- fromSnapMergingTree hfs hbio uc resolve activeDir reg snapTree
-                traverse_ (delayedCommit reg . releaseRef) snapTree
-                pure (Union mt)
+                isStructurallyEmpty mt >>= \case
+                  True ->
+                    pure NoUnion
+                  False -> do
+                    traverse_ (delayedCommit reg . releaseRef) snapTree
+                    cache <- mkUnionCache reg mt
+                    pure (Union mt cache)
 
         -- Convert from the snapshot format, restoring merge progress in the process
         tableLevels <- fromSnapLevels hfs hbio uc conf resolve reg activeDir snapLevels'
@@ -1574,7 +1574,6 @@ unionsInOpenSession ::
   -> NonEmpty (Table m h)
   -> m (Table m h)
 unionsInOpenSession reg sesh seshEnv conf ts = do
-
     mts <- forM (NE.toList ts) $ \t ->
       withOpenTable t $ \tEnv ->
         RW.withReadAccess (tableContent tEnv) $ \tc ->
@@ -1591,13 +1590,20 @@ unionsInOpenSession reg sesh seshEnv conf ts = do
     -- the action registry bracket
     forM_ mts (delayedCommit reg . releaseRef)
 
-    empty <- newEmptyTableContent seshEnv reg
-    let content = empty { tableUnionLevel = Union mt }
-
-        -- Pick the arena manager to optimise the case of:
-        -- someUpdates <> bigTableWithLotsOfLookups
-        -- by reusing the arena manager from the last one.
-        am = tableArenaManager (NE.last ts)
+    content <- MT.isStructurallyEmpty mt >>= \case
+      True -> do
+        -- no need to have an empty merging tree
+        delayedCommit reg (releaseRef mt)
+        newEmptyTableContent seshEnv reg
+      False -> do
+        empty <- newEmptyTableContent seshEnv reg
+        cache <- mkUnionCache reg mt
+        return empty { tableUnionLevel = Union mt cache }
+
+    -- Pick the arena manager to optimise the case of:
+    -- someUpdates <> bigTableWithLotsOfLookups
+    -- by reusing the arena manager from the last one.
+    let am = tableArenaManager (NE.last ts)
 
     newWith reg sesh seshEnv conf am content
 
@@ -1625,8 +1631,9 @@ tableContentToMergingTree seshEnv conf
               ++ concatMap levelToPreExistingRuns (V.toList tableLevels)
           -- any pre-existing union in the input table:
           unionmt = case tableUnionLevel of
-                    NoUnion  -> Nothing
-                    Union mt -> Just mt
+                    NoUnion    -> Nothing
+                    Union mt _ -> Just mt  -- we could re-use the cache, but it
+                                           -- would complicate things
        in newPendingLevelMerge runs unionmt
   where
     levelToPreExistingRuns :: Level m h -> [PreExistingRun m h]
@@ -1719,7 +1726,7 @@ remainingUnionDebt t = do
         case tableUnionLevel tableContent of
           NoUnion ->
             pure (UnionDebt 0)
-          Union mt -> do
+          Union mt _ -> do
             (MergeDebt (MergeCredits c), _) <- MT.remainingMergeDebt mt
             pure (UnionDebt c)
 
@@ -1736,14 +1743,15 @@ supplyUnionCredits ::
 supplyUnionCredits resolve t credits = do
     traceWith (tableTracer t) $ TraceSupplyUnionCredits credits
     withOpenTable t $ \tEnv -> do
-      -- No need to mutate the table content here. In the rare case that we want
-      -- to move a completed union level into the regular levels, we can still
-      -- take the write lock for that.
-      RW.withReadAccess (tableContent tEnv) $ \tableContent -> do
-        case tableUnionLevel tableContent of
+      -- We also want to mutate the table content to re-build the union cache,
+      -- but we don't need to hold a writer lock while we work on the tree
+      -- itself.
+      -- TODO: revisit the locking strategy here.
+      leftovers <- RW.withReadAccess (tableContent tEnv) $ \tc -> do
+        case tableUnionLevel tc of
           NoUnion ->
             pure (max 0 credits)  -- all leftovers (but never negative)
-          Union mt -> do
+          Union mt _ -> do
             let conf = tableConfig t
             let AllocNumEntries (NumEntries x) = confWriteBufferAlloc conf
             -- We simply use the write buffer size as merge credit threshold, as
@@ -1762,3 +1770,20 @@ supplyUnionCredits resolve t credits = do
                 mt
                 (let UnionCredits c = credits in MergeCredits c)
             pure (UnionCredits leftovers)
+      -- TODO: don't go into this section if we know there is NoUnion
+      modifyWithActionRegistry_
+        (RW.unsafeAcquireWriteAccess (tableContent tEnv))
+        (atomically . RW.unsafeReleaseWriteAccess (tableContent tEnv))
+        $ \reg tc ->
+          case tableUnionLevel tc of
+            NoUnion -> pure tc
+            Union mt cache -> do
+              unionLevel' <- MT.isStructurallyEmpty mt >>= \case
+                True  ->
+                  return NoUnion
+                False -> do
+                  cache' <- mkUnionCache reg mt
+                  releaseUnionCache reg cache
+                  return (Union mt cache')
+              pure tc { tableUnionLevel = unionLevel' }
+      pure leftovers
diff --git a/src/Database/LSMTree/Internal/MergeSchedule.hs b/src/Database/LSMTree/Internal/MergeSchedule.hs
index e0dde0527..9dc6e5a38 100644
--- a/src/Database/LSMTree/Internal/MergeSchedule.hs
+++ b/src/Database/LSMTree/Internal/MergeSchedule.hs
@@ -28,6 +28,10 @@ module Database.LSMTree.Internal.MergeSchedule (
   , mergingRunParamsForLevel
     -- * Union level
   , UnionLevel (..)
+    -- * Union cache
+  , UnionCache (..)
+  , mkUnionCache
+  , releaseUnionCache
     -- * Flushes and scheduled merges
   , updatesWithInterleavedFlushes
   , flushWriteBuffer
@@ -54,7 +58,7 @@ import           Control.Monad.Primitive
 import           Control.RefCount
 import           Control.Tracer
 import           Data.BloomFilter (Bloom)
-import           Data.Foldable (fold)
+import           Data.Foldable (fold, traverse_)
 import qualified Data.Vector as V
 import           Database.LSMTree.Internal.Assertions (assert)
 import           Database.LSMTree.Internal.Config
@@ -67,6 +71,7 @@ import           Database.LSMTree.Internal.MergingRun (MergeCredits (..),
                      MergeDebt (..), MergingRun, RunParams (..))
 import qualified Database.LSMTree.Internal.MergingRun as MR
 import           Database.LSMTree.Internal.MergingTree (MergingTree)
+import qualified Database.LSMTree.Internal.MergingTree.Lookup as MT
 import           Database.LSMTree.Internal.Paths (ActiveDir, RunFsPaths (..),
                      SessionRoot)
 import qualified Database.LSMTree.Internal.Paths as Paths
@@ -76,7 +81,8 @@ import           Database.LSMTree.Internal.RunNumber
 import           Database.LSMTree.Internal.Serialise (SerialisedBlob,
                      SerialisedKey, SerialisedValue)
 import           Database.LSMTree.Internal.UniqCounter
-import           Database.LSMTree.Internal.Vector (forMStrict, mapStrict)
+import           Database.LSMTree.Internal.Vector (forMStrict, mapMStrict,
+                     mapStrict)
 import           Database.LSMTree.Internal.WriteBuffer (WriteBuffer)
 import qualified Database.LSMTree.Internal.WriteBuffer as WB
 import           Database.LSMTree.Internal.WriteBufferBlobs (WriteBufferBlobs)
@@ -141,7 +147,7 @@ data TableContent m h = TableContent {
   , tableLevels           :: !(Levels m h)
     -- | Cache of flattened regular 'levels'.
   , tableCache            :: !(LevelsCache m h)
-    -- | An optional final union level, not included in the table cache.
+    -- | An optional final union level, containing its own cache.
   , tableUnionLevel       :: !(UnionLevel m h)
   }
 
@@ -356,7 +362,7 @@ iforLevelM_ lvls k = V.iforM_ lvls $ \i lvl -> k (LevelNo (i + 1)) lvl
 -- * never merged into the regular levels
 data UnionLevel m h =
     NoUnion
-  | Union !(Ref (MergingTree m h))
+  | Union !(Ref (MergingTree m h)) !(UnionCache m h)
 
 {-# SPECIALISE duplicateUnionLevel ::
      ActionRegistry IO
@@ -369,8 +375,9 @@ duplicateUnionLevel ::
   -> m (UnionLevel m h)
 duplicateUnionLevel reg ul =
     case ul of
-      NoUnion    -> return ul
-      Union tree -> Union <$> withRollback reg (dupRef tree) releaseRef
+      NoUnion          -> return ul
+      Union tree cache -> Union <$> withRollback reg (dupRef tree) releaseRef
+                                <*> duplicateUnionCache reg cache
 
 {-# SPECIALISE releaseUnionLevel ::
      ActionRegistry IO
@@ -381,8 +388,44 @@ releaseUnionLevel ::
   => ActionRegistry m
   -> UnionLevel m h
   -> m ()
-releaseUnionLevel _   NoUnion      = return ()
-releaseUnionLevel reg (Union tree) = delayedCommit reg (releaseRef tree)
+releaseUnionLevel _   NoUnion            = return ()
+releaseUnionLevel reg (Union tree cache) = delayedCommit reg (releaseRef tree)
+                                        >> releaseUnionCache reg cache
+
+{-------------------------------------------------------------------------------
+  Union cache
+-------------------------------------------------------------------------------}
+
+-- | Similar to the 'LevelsCache', but in a tree shape, since this structure is
+-- required to combine the individual lookup results.
+newtype UnionCache m h = UnionCache {
+    cachedTree :: MT.LookupTree (V.Vector (Ref (Run m h)))
+  }
+
+mkUnionCache ::
+     (PrimMonad m, MonadMVar m, MonadMask m)
+  => ActionRegistry m
+  -> Ref (MergingTree m h)
+  -> m (UnionCache m h)
+mkUnionCache reg mt =
+    UnionCache <$> MT.buildLookupTree reg mt
+
+duplicateUnionCache ::
+     (PrimMonad m, MonadMask m)
+  => ActionRegistry m
+  -> UnionCache m h
+  -> m (UnionCache m h)
+duplicateUnionCache reg (UnionCache mt) =
+    UnionCache <$>
+      MT.mapMStrict (mapMStrict (\r -> withRollback reg (dupRef r) releaseRef)) mt
+
+releaseUnionCache ::
+     (PrimMonad m, MonadMask m)
+  => ActionRegistry m
+  -> UnionCache m h
+  -> m ()
+releaseUnionCache reg (UnionCache mt) =
+    traverse_ (traverse_ (\r -> delayedCommit reg (releaseRef r))) mt
 
 {-------------------------------------------------------------------------------
   Flushes and scheduled merges
diff --git a/src/Database/LSMTree/Internal/MergingRun.hs b/src/Database/LSMTree/Internal/MergingRun.hs
index 4b57c28f2..dbb977844 100644
--- a/src/Database/LSMTree/Internal/MergingRun.hs
+++ b/src/Database/LSMTree/Internal/MergingRun.hs
@@ -74,6 +74,7 @@ import qualified Database.LSMTree.Internal.Merge as Merge
 import           Database.LSMTree.Internal.Paths (RunFsPaths (..))
 import           Database.LSMTree.Internal.Run (Run)
 import qualified Database.LSMTree.Internal.Run as Run
+import qualified Database.LSMTree.Internal.Vector as V
 import           GHC.Stack (HasCallStack, callStack)
 import           System.FS.API (HasFS)
 import           System.FS.BlockIO.API (HasBlockIO)
@@ -275,7 +276,7 @@ duplicateRuns (DeRef mr) =
     withMVar (mergeState mr) $ \case
       CompletedMerge r  -> V.singleton <$> dupRef r
       OngoingMerge rs _ -> withActionRegistry $ \reg ->
-        V.mapM (\r -> withRollback reg (dupRef r) releaseRef) rs
+        V.mapMStrict (\r -> withRollback reg (dupRef r) releaseRef) rs
 
 -- | Take a snapshot of the state of a merging run.
 --
diff --git a/src/Database/LSMTree/Internal/MergingTree/Lookup.hs b/src/Database/LSMTree/Internal/MergingTree/Lookup.hs
index 8979016a9..02507f6d6 100644
--- a/src/Database/LSMTree/Internal/MergingTree/Lookup.hs
+++ b/src/Database/LSMTree/Internal/MergingTree/Lookup.hs
@@ -1,20 +1,20 @@
 module Database.LSMTree.Internal.MergingTree.Lookup (
     LookupTree (..)
+  , mapMStrict
   , mkLookupNode
   , buildLookupTree
-  , releaseLookupTree
   , foldLookupTree
   ) where
 
 import           Control.ActionRegistry
 import           Control.Concurrent.Class.MonadMVar.Strict
 import           Control.Exception (assert)
+import           Control.Monad
 import           Control.Monad.Class.MonadAsync (Async, MonadAsync)
 import qualified Control.Monad.Class.MonadAsync as Async
 import           Control.Monad.Class.MonadThrow (MonadMask)
 import           Control.Monad.Primitive
 import           Control.RefCount
-import           Data.Foldable (traverse_)
 import qualified Data.Vector as V
 import qualified Database.LSMTree.Internal.Entry as Entry
 import           Database.LSMTree.Internal.Lookup (LookupAcc,
@@ -22,13 +22,21 @@ import           Database.LSMTree.Internal.Lookup (LookupAcc,
 import qualified Database.LSMTree.Internal.MergingRun as MR
 import qualified Database.LSMTree.Internal.MergingTree as MT
 import           Database.LSMTree.Internal.Run (Run)
+import qualified Database.LSMTree.Internal.Vector as V
 
 -- | A simplified representation of the shape of a 'MT.MergingTree'.
 data LookupTree a =
     LookupBatch !a
     -- | Use 'mkLookupNode' to construct this.
-  | LookupNode !MR.TreeMergeType !(V.Vector (LookupTree a))  -- ^ length 2 or more
-  deriving stock (Foldable, Functor, Traversable)
+  | LookupNode !MR.TreeMergeType !(V.Vector (LookupTree a)) -- ^ length 2 or more
+  deriving stock (Foldable)
+
+-- | Deriving 'Traversable' leads to functions that are not strict in the
+-- elements of the vector of children. This function avoids that issue.
+mapMStrict :: Monad m => (a -> m b) -> LookupTree a -> m (LookupTree b)
+mapMStrict f = \case
+  LookupBatch a  -> LookupBatch <$!> f a
+  LookupNode t v -> LookupNode t <$!> V.mapMStrict (mapMStrict f) v
 
 -- | Asserts that the vector is non-empty. Collapses singleton nodes.
 mkLookupNode :: MR.TreeMergeType -> V.Vector (LookupTree a) -> LookupTree a
@@ -79,8 +87,8 @@ mergeLookupAcc resolve mt accs =
 --
 -- Assumes that the merging tree is not 'MT.isStructurallyEmpty'.
 --
--- This function duplicates the references to all the tree's runs.
--- These references later need to be released using 'releaseLookupTree'.
+-- This function duplicates the references to all the tree's runs. These
+-- references later need to be released.
 {-# SPECIALISE buildLookupTree ::
      ActionRegistry IO
   -> Ref (MT.MergingTree IO h)
@@ -95,40 +103,33 @@ buildLookupTree reg (DeRef mt) =
     -- dropped before we duplicated the reference.
     withMVar (MT.mergeState mt) $ \case
       MT.CompletedTreeMerge r ->
-        LookupBatch . V.singleton <$> dupRun r
+        LookupBatch . V.singleton <$!> dupRun r
       MT.OngoingTreeMerge mr -> do
-        rs <- withRollback reg (MR.duplicateRuns mr) (V.mapM_ releaseRef)
+        !rs <- withRollback reg (MR.duplicateRuns mr) (V.mapM_ releaseRef)
         ty <- MR.mergeType mr
         return $ case ty of
           Nothing            -> LookupBatch rs  -- just one run
           Just MR.MergeLevel -> LookupBatch rs  -- combine runs
           Just MR.MergeUnion -> mkLookupNode MR.MergeUnion  -- separate
-                                  (LookupBatch . V.singleton <$> rs)
+                                  (LookupBatch . V.singleton <$!> rs)
       MT.PendingTreeMerge (MT.PendingLevelMerge prs Nothing) -> do
-        LookupBatch . V.concat . V.toList <$>  -- combine runs
-          traverse duplicatePreExistingRun prs
+        LookupBatch . V.concatMap id <$!>  -- combine runs
+          V.mapMStrict duplicatePreExistingRun prs
       MT.PendingTreeMerge (MT.PendingLevelMerge prs (Just tree)) -> do
-        child <- buildLookupTree reg tree
+        !child <- buildLookupTree reg tree
         if V.null prs
           then return child
           else do
             preExisting <- do
-              LookupBatch . V.concat . V.toList <$>  -- combine runs
-                traverse duplicatePreExistingRun prs
+              LookupBatch . V.concatMap id <$!>  -- combine runs
+                V.mapMStrict duplicatePreExistingRun prs
             return $ mkLookupNode MR.MergeLevel $ V.fromList [preExisting, child]
       MT.PendingTreeMerge (MT.PendingUnionMerge trees) ->
-        mkLookupNode MR.MergeUnion <$> traverse (buildLookupTree reg) trees
+        mkLookupNode MR.MergeUnion <$!> V.mapMStrict (buildLookupTree reg) trees
   where
     dupRun r = withRollback reg (dupRef r) releaseRef
 
     duplicatePreExistingRun (MT.PreExistingRun r) =
-        V.singleton <$> dupRun r
+        V.singleton <$!> dupRun r
     duplicatePreExistingRun (MT.PreExistingMergingRun mr) =
         withRollback reg (MR.duplicateRuns mr) (V.mapM_ releaseRef)
-
-{-# SPECIALISE releaseLookupTree ::
-     ActionRegistry IO -> LookupTree (V.Vector (Ref (Run IO h))) -> IO () #-}
-releaseLookupTree ::
-     (PrimMonad m, MonadMask m)
-  => ActionRegistry m -> LookupTree (V.Vector (Ref (Run m h))) -> m ()
-releaseLookupTree reg = traverse_ (traverse_ (delayedCommit reg . releaseRef))
diff --git a/test/Test/Database/LSMTree/Internal/MergingTree.hs b/test/Test/Database/LSMTree/Internal/MergingTree.hs
index 58fb54f41..d7fa72805 100644
--- a/test/Test/Database/LSMTree/Internal/MergingTree.hs
+++ b/test/Test/Database/LSMTree/Internal/MergingTree.hs
@@ -7,7 +7,7 @@ import           Control.Exception (bracket)
 import           Control.Monad.Class.MonadAsync as Async
 import           Control.RefCount
 import           Data.Coerce (coerce)
-import           Data.Foldable (toList)
+import           Data.Foldable (toList, traverse_)
 import           Data.List.NonEmpty (NonEmpty)
 import           Data.Map (Map)
 import qualified Data.Map as Map
@@ -158,9 +158,9 @@ prop_lookupTree hfs hbio keys mtd = do
             return $ V.map (const Nothing) keys
           False -> do
             batches <- buildLookupTree reg tree
-            results <- traverse (performLookups mgr) batches
+            results <- mapMStrict (performLookups mgr) batches
             acc <- foldLookupTree resolveVal results
-            releaseLookupTree reg batches
+            traverse_ (traverse_ (delayedCommit reg . releaseRef)) batches
             return acc
 
     performLookups mgr runs =
diff --git a/test/Test/Database/LSMTree/UnitTests.hs b/test/Test/Database/LSMTree/UnitTests.hs
index 75b27f448..2ee04fde0 100644
--- a/test/Test/Database/LSMTree/UnitTests.hs
+++ b/test/Test/Database/LSMTree/UnitTests.hs
@@ -6,6 +6,7 @@ module Test.Database.LSMTree.UnitTests (tests) where
 import           Control.Tracer (nullTracer)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS
+import           Data.Foldable (for_)
 import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map as Map
 import qualified Data.Vector as V
@@ -35,6 +36,7 @@ tests =
       , testCase      "unit_unions_1"       unit_unions_1
       , testCase      "unit_union_credits"  unit_union_credits
       , testCase      "unit_union_credit_0" unit_union_credit_0
+      , testCase      "unit_union_blobref_invalidation" unit_union_blobref_invalidation
       ]
 
 unit_blobs :: (String -> IO ()) -> Assertion
@@ -212,6 +214,40 @@ unit_union_credit_0 =
         r <- lookups table' [Key1 17]
         V.map ignoreBlobRef r @?= [Found (Value1 42)]
 
+-- | 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 =
+    withTempIOHasBlockIO "test" $ \hfs hbio ->
+    withSession nullTracer hfs hbio (FS.mkFsPath []) $ \sess -> do
+      t1 <- new @_ @Key1 @Value1 @Blob1 sess config
+      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])
+
+      -- progress original table (supplying merge credits would be most direct),
+      -- so merges complete
+      inserts t1 (fmap (\i -> (Key1 i, Value1 i, Nothing)) [1000..2000])
+      -- close it, so it doesn't hold open extra references
+      close t1
+
+      -- try to resolve the blob refs we obtained earlier
+      _blobs <- retrieveBlobs sess (V.mapMaybe getBlobRef res)
+      return ()
+  where
+    config = defaultTableConfig {
+        confWriteBufferAlloc = AllocNumEntries (NumEntries 4)
+      }
+
+getBlobRef :: LookupResult v b -> Maybe b
+getBlobRef = \case
+  NotFound          -> Nothing
+  Found _           -> Nothing
+  FoundWithBlob _ b -> Just b
+
 ignoreBlobRef :: Functor f => f (BlobRef m b) -> f ()
 ignoreBlobRef = fmap (const ())
 


Reviews:
user: login: jorisdral
body: I think this looks okay!

BTW, I added 4e6b2e4b49a4e1461d0c24bda5c2183217a919ce. Feel free to do with it what you want, but I thought it would be an alternative to making the `NoThunks` checks happy with fewer changes in the code (though at the time of writing I'm still waiting for CI to finish to see if there are any `NoThunks` failures)
state: APPROVED
author_association: COLLABORATOR
submitted_at: 2025-04-08T10:25:41Z
user: login: mheinzel
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-04-08T10:56:35Z
user: login: mheinzel
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-04-08T11:00:57Z
user: login: jorisdral
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-04-08T11:07:02Z
user: login: jorisdral
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-04-08T11:07:23Z
user: login: jorisdral
state: COMMENTED
author_association: COLLABORATOR
submitted_at: 2025-04-08T11:16:51Z

Review comments:
diff_hunk: @@ -1,40 +1,48 @@
 module Database.LSMTree.Internal.MergingTree.Lookup (
     LookupTree (..)
+  , mapMStrict
   , mkLookupNode
   , buildLookupTree
-  , releaseLookupTree
   , foldLookupTree
   ) where
 
 import           Control.ActionRegistry
 import           Control.Concurrent.Class.MonadMVar.Strict
 import           Control.Exception (assert)
+import           Control.Monad
 import           Control.Monad.Class.MonadAsync (Async, MonadAsync)
 import qualified Control.Monad.Class.MonadAsync as Async
 import           Control.Monad.Class.MonadThrow (MonadMask)
 import           Control.Monad.Primitive
 import           Control.RefCount
-import           Data.Foldable (traverse_)
 import qualified Data.Vector as V
 import qualified Database.LSMTree.Internal.Entry as Entry
 import           Database.LSMTree.Internal.Lookup (LookupAcc,
                      ResolveSerialisedValue)
 import qualified Database.LSMTree.Internal.MergingRun as MR
 import qualified Database.LSMTree.Internal.MergingTree as MT
 import           Database.LSMTree.Internal.Run (Run)
+import qualified Database.LSMTree.Internal.Vector as V
 
 -- | A simplified representation of the shape of a 'MT.MergingTree'.
 data LookupTree a =
     LookupBatch !a
     -- | Use 'mkLookupNode' to construct this.
-  | LookupNode !MR.TreeMergeType !(V.Vector (LookupTree a))  -- ^ length 2 or more
-  deriving stock (Foldable, Functor, Traversable)
+  | LookupNode !MR.TreeMergeType !(V.Vector (LookupTree a)) -- ^ length 2 or more
+  deriving stock (Foldable)
+
+-- | Deriving 'Traversable' leads to functions that are not strict in the
+-- elements of the vector of children. This function avoids that issue.
+mapMStrict :: Monad m => (a -> m b) -> LookupTree a -> m (LookupTree b)
+mapMStrict f = \case
+  LookupBatch a  -> LookupBatch <$> f a
+  LookupNode t v -> LookupNode t . V.mapStrict id <$> traverse (mapMStrict f) v
 
 -- | Asserts that the vector is non-empty. Collapses singleton nodes.
 mkLookupNode :: MR.TreeMergeType -> V.Vector (LookupTree a) -> LookupTree a
 mkLookupNode ty ts
   | assert (not (null ts)) (V.length ts == 1) = V.head ts
-  | otherwise                                 = LookupNode ty ts
+  | otherwise                                 = LookupNode ty (id <$!> ts)
path: src/Database/LSMTree/Internal/MergingTree/Lookup.hs
user: login: jorisdral
body: This strict map seems not ideal -- was this necessary to make `NoThunks` checks happy?
created_at: 2025-04-08T09:04:59Z
author_association: COLLABORATOR
diff_hunk: @@ -103,32 +111,25 @@ buildLookupTree reg (DeRef mt) =
           Nothing            -> LookupBatch rs  -- just one run
           Just MR.MergeLevel -> LookupBatch rs  -- combine runs
           Just MR.MergeUnion -> mkLookupNode MR.MergeUnion  -- separate
-                                  (LookupBatch . V.singleton <$> rs)
+                                  (LookupBatch . V.singleton <$!> rs)
       MT.PendingTreeMerge (MT.PendingLevelMerge prs Nothing) -> do
-        LookupBatch . V.concat . V.toList <$>  -- combine runs
-          traverse duplicatePreExistingRun prs
+        LookupBatch . V.concat . V.toList <$!>  -- combine runs
+          mapM duplicatePreExistingRun prs
       MT.PendingTreeMerge (MT.PendingLevelMerge prs (Just tree)) -> do
-        child <- buildLookupTree reg tree
+        !child <- buildLookupTree reg tree
         if V.null prs
           then return child
           else do
-            preExisting <- do
+            !preExisting <- do
               LookupBatch . V.concat . V.toList <$>  -- combine runs
-                traverse duplicatePreExistingRun prs
+                mapM duplicatePreExistingRun prs
             return $ mkLookupNode MR.MergeLevel $ V.fromList [preExisting, child]
       MT.PendingTreeMerge (MT.PendingUnionMerge trees) ->
-        mkLookupNode MR.MergeUnion <$> traverse (buildLookupTree reg) trees
+        mkLookupNode MR.MergeUnion <$!> mapM (buildLookupTree reg) trees
   where
     dupRun r = withRollback reg (dupRef r) releaseRef
 
     duplicatePreExistingRun (MT.PreExistingRun r) =
         V.singleton <$> dupRun r
     duplicatePreExistingRun (MT.PreExistingMergingRun mr) =
         withRollback reg (MR.duplicateRuns mr) (V.mapM_ releaseRef)
-
-{-# SPECIALISE releaseLookupTree ::
-     ActionRegistry IO -> LookupTree (V.Vector (Ref (Run IO h))) -> IO () #-}
-releaseLookupTree ::
-     (PrimMonad m, MonadMask m)
-  => ActionRegistry m -> LookupTree (V.Vector (Ref (Run m h))) -> m ()
-releaseLookupTree reg = traverse_ (traverse_ (delayedCommit reg . releaseRef))
path: src/Database/LSMTree/Internal/MergingTree/Lookup.hs
user: login: jorisdral
body: Why did you decide to remove this? I think it was kind of nice that there was one function that you could tell users to use when releasing a lookup tree
created_at: 2025-04-08T09:06:22Z
author_association: COLLABORATOR
diff_hunk: @@ -1,40 +1,48 @@
 module Database.LSMTree.Internal.MergingTree.Lookup (
     LookupTree (..)
+  , mapMStrict
   , mkLookupNode
   , buildLookupTree
-  , releaseLookupTree
   , foldLookupTree
   ) where
 
 import           Control.ActionRegistry
 import           Control.Concurrent.Class.MonadMVar.Strict
 import           Control.Exception (assert)
+import           Control.Monad
 import           Control.Monad.Class.MonadAsync (Async, MonadAsync)
 import qualified Control.Monad.Class.MonadAsync as Async
 import           Control.Monad.Class.MonadThrow (MonadMask)
 import           Control.Monad.Primitive
 import           Control.RefCount
-import           Data.Foldable (traverse_)
 import qualified Data.Vector as V
 import qualified Database.LSMTree.Internal.Entry as Entry
 import           Database.LSMTree.Internal.Lookup (LookupAcc,
                      ResolveSerialisedValue)
 import qualified Database.LSMTree.Internal.MergingRun as MR
 import qualified Database.LSMTree.Internal.MergingTree as MT
 import           Database.LSMTree.Internal.Run (Run)
+import qualified Database.LSMTree.Internal.Vector as V
 
 -- | A simplified representation of the shape of a 'MT.MergingTree'.
 data LookupTree a =
     LookupBatch !a
     -- | Use 'mkLookupNode' to construct this.
-  | LookupNode !MR.TreeMergeType !(V.Vector (LookupTree a))  -- ^ length 2 or more
-  deriving stock (Foldable, Functor, Traversable)
+  | LookupNode !MR.TreeMergeType !(V.Vector (LookupTree a)) -- ^ length 2 or more
+  deriving stock (Foldable)
+
+-- | Deriving 'Traversable' leads to functions that are not strict in the
+-- elements of the vector of children. This function avoids that issue.
+mapMStrict :: Monad m => (a -> m b) -> LookupTree a -> m (LookupTree b)
+mapMStrict f = \case
+  LookupBatch a  -> LookupBatch <$> f a
+  LookupNode t v -> LookupNode t . V.mapStrict id <$> traverse (mapMStrict f) v
 
 -- | Asserts that the vector is non-empty. Collapses singleton nodes.
 mkLookupNode :: MR.TreeMergeType -> V.Vector (LookupTree a) -> LookupTree a
 mkLookupNode ty ts
   | assert (not (null ts)) (V.length ts == 1) = V.head ts
-  | otherwise                                 = LookupNode ty ts
+  | otherwise                                 = LookupNode ty (id <$!> ts)
path: src/Database/LSMTree/Internal/MergingTree/Lookup.hs
user: login: jorisdral
body: I'm thinking whether we could remove `id <$!> ts` if we use `Database.LSMTree.Internal.Vector.mapMStrict` 
created_at: 2025-04-08T09:08:19Z
author_association: COLLABORATOR
diff_hunk: @@ -1,40 +1,48 @@
 module Database.LSMTree.Internal.MergingTree.Lookup (
     LookupTree (..)
+  , mapMStrict
   , mkLookupNode
   , buildLookupTree
-  , releaseLookupTree
   , foldLookupTree
   ) where
 
 import           Control.ActionRegistry
 import           Control.Concurrent.Class.MonadMVar.Strict
 import           Control.Exception (assert)
+import           Control.Monad
 import           Control.Monad.Class.MonadAsync (Async, MonadAsync)
 import qualified Control.Monad.Class.MonadAsync as Async
 import           Control.Monad.Class.MonadThrow (MonadMask)
 import           Control.Monad.Primitive
 import           Control.RefCount
-import           Data.Foldable (traverse_)
 import qualified Data.Vector as V
 import qualified Database.LSMTree.Internal.Entry as Entry
 import           Database.LSMTree.Internal.Lookup (LookupAcc,
                      ResolveSerialisedValue)
 import qualified Database.LSMTree.Internal.MergingRun as MR
 import qualified Database.LSMTree.Internal.MergingTree as MT
 import           Database.LSMTree.Internal.Run (Run)
+import qualified Database.LSMTree.Internal.Vector as V
 
 -- | A simplified representation of the shape of a 'MT.MergingTree'.
 data LookupTree a =
     LookupBatch !a
     -- | Use 'mkLookupNode' to construct this.
-  | LookupNode !MR.TreeMergeType !(V.Vector (LookupTree a))  -- ^ length 2 or more
-  deriving stock (Foldable, Functor, Traversable)
+  | LookupNode !MR.TreeMergeType !(V.Vector (LookupTree a)) -- ^ length 2 or more
+  deriving stock (Foldable)
+
+-- | Deriving 'Traversable' leads to functions that are not strict in the
+-- elements of the vector of children. This function avoids that issue.
+mapMStrict :: Monad m => (a -> m b) -> LookupTree a -> m (LookupTree b)
+mapMStrict f = \case
+  LookupBatch a  -> LookupBatch <$> f a
+  LookupNode t v -> LookupNode t . V.mapStrict id <$> traverse (mapMStrict f) v
 
 -- | Asserts that the vector is non-empty. Collapses singleton nodes.
 mkLookupNode :: MR.TreeMergeType -> V.Vector (LookupTree a) -> LookupTree a
 mkLookupNode ty ts
   | assert (not (null ts)) (V.length ts == 1) = V.head ts
-  | otherwise                                 = LookupNode ty ts
+  | otherwise                                 = LookupNode ty (id <$!> ts)
path: src/Database/LSMTree/Internal/MergingTree/Lookup.hs
user: login: mheinzel
body: I wanted to force it here so callers of `mkLookupNode` don't have to. But I agree that it's probably better overall to let the callers do it, as they often don't have to do an extra traversal of the vector.
created_at: 2025-04-08T10:56:35Z
author_association: COLLABORATOR
diff_hunk: @@ -103,32 +111,25 @@ buildLookupTree reg (DeRef mt) =
           Nothing            -> LookupBatch rs  -- just one run
           Just MR.MergeLevel -> LookupBatch rs  -- combine runs
           Just MR.MergeUnion -> mkLookupNode MR.MergeUnion  -- separate
-                                  (LookupBatch . V.singleton <$> rs)
+                                  (LookupBatch . V.singleton <$!> rs)
       MT.PendingTreeMerge (MT.PendingLevelMerge prs Nothing) -> do
-        LookupBatch . V.concat . V.toList <$>  -- combine runs
-          traverse duplicatePreExistingRun prs
+        LookupBatch . V.concat . V.toList <$!>  -- combine runs
+          mapM duplicatePreExistingRun prs
       MT.PendingTreeMerge (MT.PendingLevelMerge prs (Just tree)) -> do
-        child <- buildLookupTree reg tree
+        !child <- buildLookupTree reg tree
         if V.null prs
           then return child
           else do
-            preExisting <- do
+            !preExisting <- do
               LookupBatch . V.concat . V.toList <$>  -- combine runs
-                traverse duplicatePreExistingRun prs
+                mapM duplicatePreExistingRun prs
             return $ mkLookupNode MR.MergeLevel $ V.fromList [preExisting, child]
       MT.PendingTreeMerge (MT.PendingUnionMerge trees) ->
-        mkLookupNode MR.MergeUnion <$> traverse (buildLookupTree reg) trees
+        mkLookupNode MR.MergeUnion <$!> mapM (buildLookupTree reg) trees
   where
     dupRun r = withRollback reg (dupRef r) releaseRef
 
     duplicatePreExistingRun (MT.PreExistingRun r) =
         V.singleton <$> dupRun r
     duplicatePreExistingRun (MT.PreExistingMergingRun mr) =
         withRollback reg (MR.duplicateRuns mr) (V.mapM_ releaseRef)
-
-{-# SPECIALISE releaseLookupTree ::
-     ActionRegistry IO -> LookupTree (V.Vector (Ref (Run IO h))) -> IO () #-}
-releaseLookupTree ::
-     (PrimMonad m, MonadMask m)
-  => ActionRegistry m -> LookupTree (V.Vector (Ref (Run m h))) -> m ()
-releaseLookupTree reg = traverse_ (traverse_ (delayedCommit reg . releaseRef))
path: src/Database/LSMTree/Internal/MergingTree/Lookup.hs
user: login: mheinzel
body: It's mainly used in `releaseUnionCache`, which is just a thin wrapper around it, so I inlined it to avoid having two separate one-liners with a 5 line signature. I can add it back.
created_at: 2025-04-08T11:00:56Z
author_association: COLLABORATOR
diff_hunk: @@ -275,7 +276,7 @@ duplicateRuns (DeRef mr) =
     withMVar (mergeState mr) $ \case
       CompletedMerge r  -> V.singleton <$> dupRef r
       OngoingMerge rs _ -> withActionRegistry $ \reg ->
-        V.mapM (\r -> withRollback reg (dupRef r) releaseRef) rs
+        V.mapMStrict (\r -> withRollback reg (dupRef r) releaseRef) rs
path: src/Database/LSMTree/Internal/MergingRun.hs
user: login: jorisdral
body: I think that this one might be superfluous because `dupRef` is already strict enough, but I forgot to take it out
created_at: 2025-04-08T11:07:02Z
author_association: COLLABORATOR
diff_hunk: @@ -103,32 +111,25 @@ buildLookupTree reg (DeRef mt) =
           Nothing            -> LookupBatch rs  -- just one run
           Just MR.MergeLevel -> LookupBatch rs  -- combine runs
           Just MR.MergeUnion -> mkLookupNode MR.MergeUnion  -- separate
-                                  (LookupBatch . V.singleton <$> rs)
+                                  (LookupBatch . V.singleton <$!> rs)
       MT.PendingTreeMerge (MT.PendingLevelMerge prs Nothing) -> do
-        LookupBatch . V.concat . V.toList <$>  -- combine runs
-          traverse duplicatePreExistingRun prs
+        LookupBatch . V.concat . V.toList <$!>  -- combine runs
+          mapM duplicatePreExistingRun prs
       MT.PendingTreeMerge (MT.PendingLevelMerge prs (Just tree)) -> do
-        child <- buildLookupTree reg tree
+        !child <- buildLookupTree reg tree
         if V.null prs
           then return child
           else do
-            preExisting <- do
+            !preExisting <- do
               LookupBatch . V.concat . V.toList <$>  -- combine runs
-                traverse duplicatePreExistingRun prs
+                mapM duplicatePreExistingRun prs
             return $ mkLookupNode MR.MergeLevel $ V.fromList [preExisting, child]
       MT.PendingTreeMerge (MT.PendingUnionMerge trees) ->
-        mkLookupNode MR.MergeUnion <$> traverse (buildLookupTree reg) trees
+        mkLookupNode MR.MergeUnion <$!> mapM (buildLookupTree reg) trees
   where
     dupRun r = withRollback reg (dupRef r) releaseRef
 
     duplicatePreExistingRun (MT.PreExistingRun r) =
         V.singleton <$> dupRun r
     duplicatePreExistingRun (MT.PreExistingMergingRun mr) =
         withRollback reg (MR.duplicateRuns mr) (V.mapM_ releaseRef)
-
-{-# SPECIALISE releaseLookupTree ::
-     ActionRegistry IO -> LookupTree (V.Vector (Ref (Run IO h))) -> IO () #-}
-releaseLookupTree ::
-     (PrimMonad m, MonadMask m)
-  => ActionRegistry m -> LookupTree (V.Vector (Ref (Run m h))) -> m ()
-releaseLookupTree reg = traverse_ (traverse_ (delayedCommit reg . releaseRef))
path: src/Database/LSMTree/Internal/MergingTree/Lookup.hs
user: login: jorisdral
body: No worries, I was just wondering why it was gone, I'm fine with your change
created_at: 2025-04-08T11:07:23Z
author_association: COLLABORATOR
diff_hunk: @@ -1,40 +1,48 @@
 module Database.LSMTree.Internal.MergingTree.Lookup (
     LookupTree (..)
+  , mapMStrict
   , mkLookupNode
   , buildLookupTree
-  , releaseLookupTree
   , foldLookupTree
   ) where
 
 import           Control.ActionRegistry
 import           Control.Concurrent.Class.MonadMVar.Strict
 import           Control.Exception (assert)
+import           Control.Monad
 import           Control.Monad.Class.MonadAsync (Async, MonadAsync)
 import qualified Control.Monad.Class.MonadAsync as Async
 import           Control.Monad.Class.MonadThrow (MonadMask)
 import           Control.Monad.Primitive
 import           Control.RefCount
-import           Data.Foldable (traverse_)
 import qualified Data.Vector as V
 import qualified Database.LSMTree.Internal.Entry as Entry
 import           Database.LSMTree.Internal.Lookup (LookupAcc,
                      ResolveSerialisedValue)
 import qualified Database.LSMTree.Internal.MergingRun as MR
 import qualified Database.LSMTree.Internal.MergingTree as MT
 import           Database.LSMTree.Internal.Run (Run)
+import qualified Database.LSMTree.Internal.Vector as V
 
 -- | A simplified representation of the shape of a 'MT.MergingTree'.
 data LookupTree a =
     LookupBatch !a
     -- | Use 'mkLookupNode' to construct this.
-  | LookupNode !MR.TreeMergeType !(V.Vector (LookupTree a))  -- ^ length 2 or more
-  deriving stock (Foldable, Functor, Traversable)
+  | LookupNode !MR.TreeMergeType !(V.Vector (LookupTree a)) -- ^ length 2 or more
+  deriving stock (Foldable)
+
+-- | Deriving 'Traversable' leads to functions that are not strict in the
+-- elements of the vector of children. This function avoids that issue.
+mapMStrict :: Monad m => (a -> m b) -> LookupTree a -> m (LookupTree b)
+mapMStrict f = \case
+  LookupBatch a  -> LookupBatch <$> f a
+  LookupNode t v -> LookupNode t . V.mapStrict id <$> traverse (mapMStrict f) v
 
 -- | Asserts that the vector is non-empty. Collapses singleton nodes.
 mkLookupNode :: MR.TreeMergeType -> V.Vector (LookupTree a) -> LookupTree a
 mkLookupNode ty ts
   | assert (not (null ts)) (V.length ts == 1) = V.head ts
-  | otherwise                                 = LookupNode ty ts
+  | otherwise                                 = LookupNode ty (id <$!> ts)
path: src/Database/LSMTree/Internal/MergingTree/Lookup.hs
user: login: jorisdral
body: I think it is fine if the callee ensures strictness, but then the callee most often has to run in an appropriate monad (like `IO`, using something like `return $!`). `mkLookupNode` is pure, so the caller has to force the result of `mkLookupNode` anyway, so it's slightly less useful here
created_at: 2025-04-08T11:16:51Z
author_association: COLLABORATOR

PR comments:
user: login: jorisdral
created_at: 2025-04-08T10:37:58Z
body: > I think this looks okay!
> 
> BTW, I added [4e6b2e4](https://github.com/IntersectMBO/lsm-tree/commit/4e6b2e4b49a4e1461d0c24bda5c2183217a919ce). Feel free to do with it what you want, but I thought it would be an alternative to making the `NoThunks` checks happy with fewer changes in the code (though at the time of writing I'm still waiting for CI to finish to see if there are any `NoThunks` failures)

Spoilers: CI failed. I was running the wrong property locally
author_association: COLLABORATOR
user: login: mheinzel
created_at: 2025-04-08T10:54:25Z
body: Yes, e.g. https://github.com/IntersectMBO/lsm-tree/actions/runs/14331148532/job/40167280339?pr=670#step:13:3134. I still think most of your changes are good. I made some quick tweaks when trying to avoid `NoThunks` failures and should have cleaned up more afterwards.
author_association: COLLABORATOR
user: login: jorisdral
created_at: 2025-04-08T11:06:36Z
body: I pushed 30a3c7626094b1e0b26ddcec2d704da32064e259 now, hopefully that one works
author_association: COLLABORATOR