From cb608304f164a7293e1f0669badbeefefaef87fb Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Tue, 14 Jan 2025 18:05:32 +0100 Subject: [PATCH] Fix a latent `NoThunks` failure We now check `NoThunks` even when assertions are disabled. With assertions enabled, some data was evaluated as part of the assertion checking, which is evaluated without assertions enabled. --- .../Database/LSMTree/Extras/NoThunks.hs | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/src-extras/Database/LSMTree/Extras/NoThunks.hs b/src-extras/Database/LSMTree/Extras/NoThunks.hs index 65bef21d0..93a2fb482 100644 --- a/src-extras/Database/LSMTree/Extras/NoThunks.hs +++ b/src-extras/Database/LSMTree/Extras/NoThunks.hs @@ -431,9 +431,22 @@ deriving stock instance Generic (RunReader m h) deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h) => NoThunks (RunReader m h) -deriving stock instance Generic (Reader.Entry m h) -deriving anyclass instance (Typeable m, Typeable (PrimState m), Typeable h) - => NoThunks (Reader.Entry m h) +-- | Allows thunks in the overflow pages +instance ( Typeable m, Typeable (PrimState m), Typeable h + ) => NoThunks (Reader.Entry m h) where + showTypeOf (p :: Proxy (Reader.Entry m h)) = show $ typeRep p + wNoThunks ctx (Reader.Entry (e :: Entry SerialisedValue (RawBlobRef m h))) = noThunks ctx e + wNoThunks ctx (EntryOverflow + (entryPrefix :: Entry SerialisedValue (RawBlobRef m h)) + (page :: RawPage) + (len :: Word32) + (overflowPages :: [RawOverflowPage]) ) = + allNoThunks [ + noThunks ctx entryPrefix + , noThunks ctx page + , noThunks ctx len + , noThunks ctx (OnlyCheckWhnf overflowPages) + ] {------------------------------------------------------------------------------- RawPage