Callstacks

Author: jorisdral

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 ()

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) =

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)