Skip to content

Commit 52c0dd3

Browse files
jorisdraljorisdral
committed
Callstacks
1 parent 2783e7c commit 52c0dd3

File tree

7 files changed

+73
-49
lines changed

7 files changed

+73
-49
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)
@@ -1246,14 +1247,14 @@ prop> inserts table entries = traverse_ (uncurry $ insert table) entries
12461247
-}
12471248
{-# SPECIALISE
12481249
inserts ::
1249-
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
1250+
(HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
12501251
Table IO k v b ->
12511252
Vector (k, v, Maybe b) ->
12521253
IO ()
12531254
#-}
12541255
inserts ::
12551256
forall m k v b.
1256-
(IOLike m) =>
1257+
(IOLike m, HasCallStack) =>
12571258
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
12581259
Table m k v b ->
12591260
Vector (k, v, Maybe b) ->
@@ -1346,14 +1347,14 @@ prop> upserts table entries = traverse_ (uncurry $ upsert table) entries
13461347
-}
13471348
{-# SPECIALISE
13481349
upserts ::
1349-
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
1350+
(HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
13501351
Table IO k v b ->
13511352
Vector (k, v) ->
13521353
IO ()
13531354
#-}
13541355
upserts ::
13551356
forall m k v b.
1356-
(IOLike m) =>
1357+
(HasCallStack, IOLike m) =>
13571358
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
13581359
Table m k v b ->
13591360
Vector (k, v) ->
@@ -1431,14 +1432,14 @@ prop> deletes table keys = traverse_ (delete table) keys
14311432
-}
14321433
{-# SPECIALISE
14331434
deletes ::
1434-
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
1435+
(HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
14351436
Table IO k v b ->
14361437
Vector k ->
14371438
IO ()
14381439
#-}
14391440
deletes ::
14401441
forall m k v b.
1441-
(IOLike m) =>
1442+
(HasCallStack, IOLike m) =>
14421443
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
14431444
Table m k v b ->
14441445
Vector k ->
@@ -1520,14 +1521,14 @@ prop> updates table entries = traverse_ (uncurry $ update table) entries
15201521
-}
15211522
{-# SPECIALISE
15221523
updates ::
1523-
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
1524+
(HasCallStack, SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
15241525
Table IO k v b ->
15251526
Vector (k, Update v b) ->
15261527
IO ()
15271528
#-}
15281529
updates ::
15291530
forall m k v b.
1530-
(IOLike m) =>
1531+
(IOLike m, HasCallStack) =>
15311532
(SerialiseKey k, SerialiseValue v, ResolveValue v, SerialiseValue b) =>
15321533
Table m k v b ->
15331534
Vector (k, Update v b) ->
@@ -2201,14 +2202,14 @@ Throws the following exceptions:
22012202
-}
22022203
{-# SPECIALISE
22032204
withCursor ::
2204-
(ResolveValue v) =>
2205+
(HasCallStack, ResolveValue v) =>
22052206
Table IO k v b ->
22062207
(Cursor IO k v b -> IO a) ->
22072208
IO a
22082209
#-}
22092210
withCursor ::
22102211
forall m k v b a.
2211-
(IOLike m) =>
2212+
(HasCallStack, IOLike m) =>
22122213
(ResolveValue v) =>
22132214
Table m k v b ->
22142215
(Cursor m k v b -> m a) ->
@@ -2231,15 +2232,15 @@ Entry (Key 1) (Value "World")
22312232
-}
22322233
{-# SPECIALISE
22332234
withCursorAtOffset ::
2234-
(SerialiseKey k, ResolveValue v) =>
2235+
(HasCallStack, SerialiseKey k, ResolveValue v) =>
22352236
Table IO k v b ->
22362237
k ->
22372238
(Cursor IO k v b -> IO a) ->
22382239
IO a
22392240
#-}
22402241
withCursorAtOffset ::
22412242
forall m k v b a.
2242-
(IOLike m) =>
2243+
(HasCallStack, IOLike m) =>
22432244
(SerialiseKey k, ResolveValue v) =>
22442245
Table m k v b ->
22452246
k ->
@@ -2278,13 +2279,13 @@ Throws the following exceptions:
22782279
-}
22792280
{-# SPECIALISE
22802281
newCursor ::
2281-
(ResolveValue v) =>
2282+
(HasCallStack, ResolveValue v) =>
22822283
Table IO k v b ->
22832284
IO (Cursor IO k v b)
22842285
#-}
22852286
newCursor ::
22862287
forall m k v b.
2287-
(IOLike m) =>
2288+
(HasCallStack, IOLike m) =>
22882289
(ResolveValue v) =>
22892290
Table m k v b ->
22902291
m (Cursor m k v b)
@@ -2306,14 +2307,14 @@ Entry (Key 1) (Value "World")
23062307
-}
23072308
{-# SPECIALISE
23082309
newCursorAtOffset ::
2309-
(SerialiseKey k, ResolveValue v) =>
2310+
(HasCallStack, SerialiseKey k, ResolveValue v) =>
23102311
Table IO k v b ->
23112312
k ->
23122313
IO (Cursor IO k v b)
23132314
#-}
23142315
newCursorAtOffset ::
23152316
forall m k v b.
2316-
(IOLike m) =>
2317+
(HasCallStack, IOLike m) =>
23172318
(SerialiseKey k, ResolveValue v) =>
23182319
Table m k v b ->
23192320
k ->
@@ -2334,12 +2335,13 @@ All other operations on a closed cursor will throw an exception.
23342335
-}
23352336
{-# SPECIALISE
23362337
closeCursor ::
2338+
HasCallStack =>
23372339
Cursor IO k v b ->
23382340
IO ()
23392341
#-}
23402342
closeCursor ::
23412343
forall m k v b.
2342-
(IOLike m) =>
2344+
(HasCallStack, IOLike m) =>
23432345
Cursor m k v b ->
23442346
m ()
23452347
closeCursor (Cursor cursor) =

‎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/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)

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

Lines changed: 12 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -153,6 +153,7 @@ import Database.LSMTree.Internal.UniqCounter
153153
import qualified Database.LSMTree.Internal.Vector as V
154154
import qualified Database.LSMTree.Internal.WriteBuffer as WB
155155
import qualified Database.LSMTree.Internal.WriteBufferBlobs as WBB
156+
import GHC.Stack (HasCallStack)
156157
import qualified System.FS.API as FS
157158
import System.FS.API (FsError, FsErrorPath (..), FsPath, HasFS)
158159
import qualified System.FS.API.Lazy as FS
@@ -1242,15 +1243,16 @@ rangeLookup resolve range t fromEntry = do
12421243
else pure (V.concat (reverse (V.slice 0 n chunk : chunks)))
12431244

12441245
{-# SPECIALISE updates ::
1245-
ResolveSerialisedValue
1246+
HasCallStack
1247+
=> ResolveSerialisedValue
12461248
-> V.Vector (SerialisedKey, Entry SerialisedValue SerialisedBlob)
12471249
-> Table IO h
12481250
-> IO () #-}
12491251
-- | See 'Database.LSMTree.updates'.
12501252
--
12511253
-- Does not enforce that upsert and BLOBs should not occur in the same table.
12521254
updates ::
1253-
(MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
1255+
(HasCallStack, MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
12541256
=> ResolveSerialisedValue
12551257
-> V.Vector (SerialisedKey, Entry SerialisedValue SerialisedBlob)
12561258
-> Table m h
@@ -1393,14 +1395,15 @@ data CursorEnv m h = CursorEnv {
13931395
}
13941396

13951397
{-# SPECIALISE withCursor ::
1396-
ResolveSerialisedValue
1398+
HasCallStack
1399+
=> ResolveSerialisedValue
13971400
-> OffsetKey
13981401
-> Table IO h
13991402
-> (Cursor IO h -> IO a)
14001403
-> IO a #-}
14011404
-- | See 'Database.LSMTree.withCursor'.
14021405
withCursor ::
1403-
(MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
1406+
(HasCallStack, MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
14041407
=> ResolveSerialisedValue
14051408
-> OffsetKey
14061409
-> Table m h
@@ -1409,13 +1412,14 @@ withCursor ::
14091412
withCursor resolve offsetKey t = bracket (newCursor resolve offsetKey t) closeCursor
14101413

14111414
{-# SPECIALISE newCursor ::
1412-
ResolveSerialisedValue
1415+
HasCallStack
1416+
=> ResolveSerialisedValue
14131417
-> OffsetKey
14141418
-> Table IO h
14151419
-> IO (Cursor IO h) #-}
14161420
-- | See 'Database.LSMTree.newCursor'.
14171421
newCursor ::
1418-
(MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
1422+
(HasCallStack, MonadMask m, MonadMVar m, MonadST m, MonadSTM m)
14191423
=> ResolveSerialisedValue
14201424
-> OffsetKey
14211425
-> Table m h
@@ -1495,10 +1499,10 @@ lookupTreeToReaderSource = \case
14951499
MR.MergeUnion -> Readers.MergeUnion
14961500
MR.MergeLevel -> Readers.MergeLevel
14971501

1498-
{-# SPECIALISE closeCursor :: Cursor IO h -> IO () #-}
1502+
{-# SPECIALISE closeCursor :: HasCallStack => Cursor IO h -> IO () #-}
14991503
-- | See 'Database.LSMTree.closeCursor'.
15001504
closeCursor ::
1501-
(MonadMask m, MonadMVar m, MonadSTM m, PrimMonad m)
1505+
(HasCallStack, MonadMask m, MonadMVar m, MonadSTM m, PrimMonad m)
15021506
=> Cursor m h
15031507
-> m ()
15041508
closeCursor Cursor {..} = do

0 commit comments

Comments
 (0)