Skip to content

Commit 6c74dd2

Browse files
jorisdraljorisdral
committed
Callstacks
1 parent bc02245 commit 6c74dd2

File tree

9 files changed

+80
-53
lines changed

9 files changed

+80
-53
lines changed

‎src/Database/LSMTree.hs‎

Lines changed: 19 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -272,6 +272,7 @@ import Database.LSMTree.Internal.Unsafe (BlobRefInvalidError (..),
272272
TableTrace, TableUnionNotCompatibleError (..),
273273
UnionCredits (..), UnionDebt (..))
274274
import qualified Database.LSMTree.Internal.Unsafe as Internal
275+
import GHC.Stack (HasCallStack)
275276
import Prelude hiding (lookup, take, takeWhile)
276277
import System.FS.API (FsPath, HasFS (..), MountPoint (..), mkFsPath)
277278
import System.FS.BlockIO.API (HasBlockIO (..), defaultIOCtxParams)
@@ -1251,14 +1252,14 @@ prop> inserts table entries = traverse_ (uncurry $ insert table) entries
12511252
-}
12521253
{-# SPECIALISE
12531254
inserts ::
1254-
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
1255+
(HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
12551256
Table IO k v b ->
12561257
Vector (k, v, Maybe b) ->
12571258
IO ()
12581259
#-}
12591260
inserts ::
12601261
forall m k v b.
1261-
(IOLike m) =>
1262+
(IOLike m, HasCallStack) =>
12621263
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
12631264
Table m k v b ->
12641265
Vector (k, v, Maybe b) ->
@@ -1351,14 +1352,14 @@ prop> upserts table entries = traverse_ (uncurry $ upsert table) entries
13511352
-}
13521353
{-# SPECIALISE
13531354
upserts ::
1354-
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
1355+
(HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
13551356
Table IO k v b ->
13561357
Vector (k, v) ->
13571358
IO ()
13581359
#-}
13591360
upserts ::
13601361
forall m k v b.
1361-
(IOLike m) =>
1362+
(HasCallStack, IOLike m) =>
13621363
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
13631364
Table m k v b ->
13641365
Vector (k, v) ->
@@ -1436,14 +1437,14 @@ prop> deletes table keys = traverse_ (delete table) keys
14361437
-}
14371438
{-# SPECIALISE
14381439
deletes ::
1439-
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
1440+
(HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
14401441
Table IO k v b ->
14411442
Vector k ->
14421443
IO ()
14431444
#-}
14441445
deletes ::
14451446
forall m k v b.
1446-
(IOLike m) =>
1447+
(HasCallStack, IOLike m) =>
14471448
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
14481449
Table m k v b ->
14491450
Vector k ->
@@ -1525,14 +1526,14 @@ prop> updates table entries = traverse_ (uncurry $ update table) entries
15251526
-}
15261527
{-# SPECIALISE
15271528
updates ::
1528-
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
1529+
(HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
15291530
Table IO k v b ->
15301531
Vector (k, Update v b) ->
15311532
IO ()
15321533
#-}
15331534
updates ::
15341535
forall m k v b.
1535-
(IOLike m) =>
1536+
(IOLike m, HasCallStack) =>
15361537
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
15371538
Table m k v b ->
15381539
Vector (k, Update v b) ->
@@ -2206,14 +2207,14 @@ Throws the following exceptions:
22062207
-}
22072208
{-# SPECIALISE
22082209
withCursor ::
2209-
(ResolveValue v) =>
2210+
(HasCallStack, ResolveValue v) =>
22102211
Table IO k v b ->
22112212
(Cursor IO k v b -> IO a) ->
22122213
IO a
22132214
#-}
22142215
withCursor ::
22152216
forall m k v b a.
2216-
(IOLike m) =>
2217+
(HasCallStack, IOLike m) =>
22172218
(ResolveValue v) =>
22182219
Table m k v b ->
22192220
(Cursor m k v b -> m a) ->
@@ -2236,15 +2237,15 @@ Entry (Key 1) (Value "World")
22362237
-}
22372238
{-# SPECIALISE
22382239
withCursorAtOffset ::
2239-
(SerialiseKey k, ResolveValue v) =>
2240+
(HasCallStack, SerialiseKey k, ResolveValue v) =>
22402241
Table IO k v b ->
22412242
k ->
22422243
(Cursor IO k v b -> IO a) ->
22432244
IO a
22442245
#-}
22452246
withCursorAtOffset ::
22462247
forall m k v b a.
2247-
(IOLike m) =>
2248+
(HasCallStack, IOLike m) =>
22482249
(SerialiseKey k, ResolveValue v) =>
22492250
Table m k v b ->
22502251
k ->
@@ -2283,13 +2284,13 @@ Throws the following exceptions:
22832284
-}
22842285
{-# SPECIALISE
22852286
newCursor ::
2286-
(ResolveValue v) =>
2287+
(HasCallStack, ResolveValue v) =>
22872288
Table IO k v b ->
22882289
IO (Cursor IO k v b)
22892290
#-}
22902291
newCursor ::
22912292
forall m k v b.
2292-
(IOLike m) =>
2293+
(HasCallStack, IOLike m) =>
22932294
(ResolveValue v) =>
22942295
Table m k v b ->
22952296
m (Cursor m k v b)
@@ -2311,14 +2312,14 @@ Entry (Key 1) (Value "World")
23112312
-}
23122313
{-# SPECIALISE
23132314
newCursorAtOffset ::
2314-
(SerialiseKey k, ResolveValue v) =>
2315+
(HasCallStack, SerialiseKey k, ResolveValue v) =>
23152316
Table IO k v b ->
23162317
k ->
23172318
IO (Cursor IO k v b)
23182319
#-}
23192320
newCursorAtOffset ::
23202321
forall m k v b.
2321-
(IOLike m) =>
2322+
(HasCallStack, IOLike m) =>
23222323
(SerialiseKey k, ResolveValue v) =>
23232324
Table m k v b ->
23242325
k ->
@@ -2339,12 +2340,13 @@ All other operations on a closed cursor will throw an exception.
23392340
-}
23402341
{-# SPECIALISE
23412342
closeCursor ::
2343+
HasCallStack =>
23422344
Cursor IO k v b ->
23432345
IO ()
23442346
#-}
23452347
closeCursor ::
23462348
forall m k v b.
2347-
(IOLike m) =>
2349+
(HasCallStack, IOLike m) =>
23482350
Cursor m k v b ->
23492351
m ()
23502352
closeCursor (Cursor cursor) =

‎src/Database/LSMTree/Internal/Merge.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,7 @@ import Database.LSMTree.Internal.RunBuilder (RunBuilder, RunParams)
4444
import qualified Database.LSMTree.Internal.RunBuilder as Builder
4545
import qualified Database.LSMTree.Internal.RunReader as Reader
4646
import Database.LSMTree.Internal.Serialise
47+
import GHC.Stack (HasCallStack)
4748
import qualified System.FS.API as FS
4849
import System.FS.API (HasFS)
4950
import System.FS.BlockIO.API (HasBlockIO)
@@ -151,7 +152,7 @@ instance IsMergeType TreeMergeType where
151152
MergeUnion -> True
152153

153154
{-# SPECIALISE new ::
154-
IsMergeType t
155+
(HasCallStack, IsMergeType t)
155156
=> HasFS IO h
156157
-> HasBlockIO IO h
157158
-> Bloom.Salt
@@ -164,7 +165,7 @@ instance IsMergeType TreeMergeType where
164165
-- | Returns 'Nothing' if no input 'Run' contains any entries.
165166
-- The list of runs should be sorted from new to old.
166167
new ::
167-
(IsMergeType t, MonadMask m, MonadSTM m, MonadST m)
168+
(HasCallStack, IsMergeType t, MonadMask m, MonadSTM m, MonadST m)
168169
=> HasFS m h
169170
-> HasBlockIO m h
170171
-> Bloom.Salt

‎src/Database/LSMTree/Internal/MergeSchedule.hs‎

Lines changed: 19 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -83,6 +83,7 @@ import Database.LSMTree.Internal.WriteBuffer (WriteBuffer)
8383
import qualified Database.LSMTree.Internal.WriteBuffer as WB
8484
import Database.LSMTree.Internal.WriteBufferBlobs (WriteBufferBlobs)
8585
import qualified Database.LSMTree.Internal.WriteBufferBlobs as WBB
86+
import GHC.Stack (HasCallStack)
8687
import qualified System.FS.API as FS
8788
import System.FS.API (HasFS)
8889
import System.FS.BlockIO.API (HasBlockIO)
@@ -198,14 +199,15 @@ data LevelsCache m h = LevelsCache_ {
198199
}
199200

200201
{-# SPECIALISE mkLevelsCache ::
201-
ActionRegistry IO
202+
HasCallStack
203+
=> ActionRegistry IO
202204
-> Levels IO h
203205
-> IO (LevelsCache IO h) #-}
204206
-- | Flatten the argument 'Level's into a single vector of runs, including all
205207
-- runs that are inputs to an ongoing merge. Use that to populate the
206208
-- 'LevelsCache'. The cache will take a reference for each of its runs.
207209
mkLevelsCache ::
208-
forall m h. (PrimMonad m, MonadMVar m, MonadMask m)
210+
forall m h. (HasCallStack, PrimMonad m, MonadMVar m, MonadMask m)
209211
=> ActionRegistry m
210212
-> Levels m h
211213
-> m (LevelsCache m h)
@@ -239,7 +241,8 @@ mkLevelsCache reg lvls = do
239241
(incoming <>) . fold <$> V.forM rs k1
240242

241243
{-# SPECIALISE rebuildCache ::
242-
ActionRegistry IO
244+
HasCallStack
245+
=> ActionRegistry IO
243246
-> LevelsCache IO h
244247
-> Levels IO h
245248
-> IO (LevelsCache IO h) #-}
@@ -264,7 +267,7 @@ mkLevelsCache reg lvls = do
264267
-- a solution to keep blob references valid until the next /update/ comes along.
265268
-- Lookups should no invalidate blob erferences.
266269
rebuildCache ::
267-
(PrimMonad m, MonadMVar m, MonadMask m)
270+
(HasCallStack, PrimMonad m, MonadMVar m, MonadMask m)
268271
=> ActionRegistry m
269272
-> LevelsCache m h -- ^ old cache
270273
-> Levels m h -- ^ new levels
@@ -274,11 +277,12 @@ rebuildCache reg oldCache newLevels = do
274277
mkLevelsCache reg newLevels
275278

276279
{-# SPECIALISE duplicateLevelsCache ::
277-
ActionRegistry IO
280+
HasCallStack
281+
=> ActionRegistry IO
278282
-> LevelsCache IO h
279283
-> IO (LevelsCache IO h) #-}
280284
duplicateLevelsCache ::
281-
(PrimMonad m, MonadMask m)
285+
(HasCallStack, PrimMonad m, MonadMask m)
282286
=> ActionRegistry m
283287
-> LevelsCache m h
284288
-> m (LevelsCache m h)
@@ -288,11 +292,12 @@ duplicateLevelsCache reg cache = do
288292
pure cache { cachedRuns = rs' }
289293

290294
{-# SPECIALISE releaseLevelsCache ::
291-
ActionRegistry IO
295+
HasCallStack
296+
=> ActionRegistry IO
292297
-> LevelsCache IO h
293298
-> IO () #-}
294299
releaseLevelsCache ::
295-
(PrimMonad m, MonadMask m)
300+
(HasCallStack, PrimMonad m, MonadMask m)
296301
=> ActionRegistry m
297302
-> LevelsCache m h
298303
-> m ()
@@ -440,7 +445,8 @@ releaseUnionCache reg (UnionCache mt) =
440445
-------------------------------------------------------------------------------}
441446

442447
{-# SPECIALISE updatesWithInterleavedFlushes ::
443-
Tracer IO (AtLevel MergeTrace)
448+
HasCallStack
449+
=> Tracer IO (AtLevel MergeTrace)
444450
-> TableConfig
445451
-> ResolveSerialisedValue
446452
-> HasFS IO h
@@ -478,7 +484,7 @@ releaseUnionCache reg (UnionCache mt) =
478484
-- whole run should then end up in a fresh write buffer.
479485
updatesWithInterleavedFlushes ::
480486
forall m h.
481-
(MonadMask m, MonadMVar m, MonadSTM m, MonadST m)
487+
(HasCallStack, MonadMask m, MonadMVar m, MonadSTM m, MonadST m)
482488
=> Tracer m (AtLevel MergeTrace)
483489
-> TableConfig
484490
-> ResolveSerialisedValue
@@ -560,7 +566,8 @@ addWriteBufferEntries hfs f wbblobs maxn =
560566

561567

562568
{-# SPECIALISE flushWriteBuffer ::
563-
Tracer IO (AtLevel MergeTrace)
569+
HasCallStack
570+
=> Tracer IO (AtLevel MergeTrace)
564571
-> TableConfig
565572
-> ResolveSerialisedValue
566573
-> HasFS IO h
@@ -576,7 +583,7 @@ addWriteBufferEntries hfs f wbblobs maxn =
576583
-- The returned table content contains an updated set of levels, where the write
577584
-- buffer is inserted into level 1.
578585
flushWriteBuffer ::
579-
(MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
586+
(HasCallStack, MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
580587
=> Tracer m (AtLevel MergeTrace)
581588
-> TableConfig
582589
-> ResolveSerialisedValue

‎src/Database/LSMTree/Internal/MergingRun.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -268,9 +268,11 @@ unsafeNew mergeDebt (SpentCredits spentCredits)
268268
-- @withRollback reg (duplicateRuns mr) (mapM_ releaseRef)@ isn't exception-safe
269269
-- since if one of the @releaseRef@ calls fails, the following ones aren't run.
270270
{-# SPECIALISE duplicateRuns ::
271-
Ref (MergingRun t IO h) -> IO (V.Vector (Ref (Run IO h))) #-}
271+
HasCallStack
272+
=> Ref (MergingRun t IO h)
273+
-> IO (V.Vector (Ref (Run IO h))) #-}
272274
duplicateRuns ::
273-
(PrimMonad m, MonadMVar m, MonadMask m)
275+
(HasCallStack, PrimMonad m, MonadMVar m, MonadMask m)
274276
=> Ref (MergingRun t m h)
275277
-> m (V.Vector (Ref (Run m h)))
276278
duplicateRuns (DeRef mr) =

‎src/Database/LSMTree/Internal/Readers.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,7 @@ import qualified Database.LSMTree.Internal.RunReader as RunReader
4343
import Database.LSMTree.Internal.Serialise
4444
import qualified Database.LSMTree.Internal.WriteBuffer as WB
4545
import qualified Database.LSMTree.Internal.WriteBufferBlobs as WB
46+
import GHC.Stack (HasCallStack)
4647
import qualified KMerge.Heap as Heap
4748
import qualified System.FS.API as FS
4849

@@ -148,12 +149,13 @@ data ReaderSource m h =
148149
| FromReaders !ReadersMergeType ![ReaderSource m h]
149150

150151
{-# SPECIALISE new ::
151-
ResolveSerialisedValue
152+
HasCallStack
153+
=> ResolveSerialisedValue
152154
-> OffsetKey
153155
-> [ReaderSource IO h]
154156
-> IO (Maybe (Readers IO h)) #-}
155157
new :: forall m h.
156-
(MonadMask m, MonadST m, MonadSTM m)
158+
(HasCallStack, MonadMask m, MonadST m, MonadSTM m)
157159
=> ResolveSerialisedValue
158160
-> OffsetKey
159161
-> [ReaderSource m h]

‎src/Database/LSMTree/Internal/RunReader.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,7 @@ import Database.LSMTree.Internal.RawOverflowPage (RawOverflowPage,
4949
import Database.LSMTree.Internal.RawPage
5050
import qualified Database.LSMTree.Internal.Run as Run
5151
import Database.LSMTree.Internal.Serialise
52+
import GHC.Stack (HasCallStack)
5253
import qualified System.FS.API as FS
5354
import System.FS.API (HasFS)
5455
import qualified System.FS.BlockIO.API as FS
@@ -93,11 +94,12 @@ data OffsetKey = NoOffsetKey | OffsetKey !SerialisedKey
9394
deriving stock Show
9495

9596
{-# SPECIALISE new ::
96-
OffsetKey
97+
HasCallStack
98+
=> OffsetKey
9799
-> Ref (Run.Run IO h)
98100
-> IO (RunReader IO h) #-}
99101
new :: forall m h.
100-
(MonadMask m, MonadSTM m, PrimMonad m)
102+
(HasCallStack, MonadMask m, MonadSTM m, PrimMonad m)
101103
=> OffsetKey
102104
-> Ref (Run.Run m h)
103105
-> m (RunReader m h)

0 commit comments

Comments
 (0)