QLS: check NoThunks only at the end of an action sequence

We sacrifice a bit of precision, but the state machine tests are already quite slow so this should speed them up a bit.
IntersectMBO · Jan 14, 2025 · 9fd4efe · 9fd4efe
1 parent 89d37dc
commit 9fd4efe
Show file tree

Hide file tree

Showing 3 changed files with 22 additions and 16 deletions.
diff --git a/src-extras/Database/LSMTree/Extras/NoThunks.hs b/src-extras/Database/LSMTree/Extras/NoThunks.hs
@@ -8,7 +8,8 @@
 -- | 'NoThunks' orphan instances
 module Database.LSMTree.Extras.NoThunks (
     assertNoThunks
-  , prop_NoThunks
+  , propUnsafeNoThunks
+  , propNoThunks
   , NoThunksIOLike
   ) where
 
@@ -80,12 +81,19 @@ assertNoThunks x = assert p
               Nothing -> True
               Just thunkInfo -> error $ "Assertion failed: found thunk" <> show thunkInfo
 
-prop_NoThunks :: NoThunks a => a -> Property
-prop_NoThunks x =
+propUnsafeNoThunks :: NoThunks a => a -> Property
+propUnsafeNoThunks x =
     case unsafeNoThunks x of
       Nothing        -> property True
       Just thunkInfo -> counterexample ("Found thunk " <> show thunkInfo) False
 
+propNoThunks :: NoThunks a => a -> IO Property
+propNoThunks x = do
+    thunkInfoMay <- noThunks [] x
+    pure $ case thunkInfoMay of
+      Nothing        -> property True
+      Just thunkInfo -> counterexample ("Found thunk " <> show thunkInfo) False
+
 {-------------------------------------------------------------------------------
   Public API
 -------------------------------------------------------------------------------}

diff --git a/test/Test/Database/LSMTree/Internal/PageAcc.hs b/test/Test/Database/LSMTree/Internal/PageAcc.hs
@@ -15,7 +15,7 @@ import           Database.LSMTree.Internal.PageAcc1
 import           Database.LSMTree.Internal.RawPage (RawPage)
 import           Database.LSMTree.Internal.Serialise
 
-import           Database.LSMTree.Extras.NoThunks (prop_NoThunks)
+import           Database.LSMTree.Extras.NoThunks (propNoThunks)
 import qualified Database.LSMTree.Extras.ReferenceImpl as Ref
 import           Test.Util.RawPage (propEqualRawPages)
 
@@ -180,15 +180,15 @@ toRawPageViaPageAcc kops0 =
 prop_noThunks_newPageAcc :: Property
 prop_noThunks_newPageAcc = once $ ioProperty $ do
     pa <- stToIO newPageAcc
-    pure $ prop_NoThunks pa
+    propNoThunks pa
 
 prop_noThunks_pageAccAddElem :: Property
 prop_noThunks_pageAccAddElem = once $ ioProperty $ do
     pa <- stToIO $ do
       pa <- newPageAcc
       pageAccAddElemN pa 10
       pure pa
-    pure $ prop_NoThunks pa
+    propNoThunks pa
 
 prop_noThunks_resetPageAcc :: Property
 prop_noThunks_resetPageAcc = once $ ioProperty $ do
@@ -197,7 +197,7 @@ prop_noThunks_resetPageAcc = once $ ioProperty $ do
       pageAccAddElemN pa 10
       resetPageAcc pa
       pure pa
-    pure $ prop_NoThunks pa
+    propNoThunks pa
 
 pageAccAddElemN :: PageAcc s -> Word64 -> ST s ()
 pageAccAddElemN pa n = do

diff --git a/test/Test/Database/LSMTree/StateMachine.hs b/test/Test/Database/LSMTree/StateMachine.hs
@@ -93,7 +93,7 @@ import           Database.LSMTree.Class (LookupResult (..), QueryResult (..))
 import qualified Database.LSMTree.Class as Class
 import           Database.LSMTree.Extras (showPowersOf)
 import           Database.LSMTree.Extras.Generators (KeyForIndexCompact)
-import           Database.LSMTree.Extras.NoThunks (assertNoThunks)
+import           Database.LSMTree.Extras.NoThunks (propNoThunks)
 import           Database.LSMTree.Internal (LSMTreeError (..))
 import qualified Database.LSMTree.Internal as R.Internal
 import           Database.LSMTree.Internal.Serialise (SerialisedBlob,
@@ -302,10 +302,12 @@ propLockstep_RealImpl_RealFS_IO tr =
         errsVar <- newTVarIO FSSim.emptyErrors
         pure (tmpDir, session, errsVar)
 
-    release :: (FilePath, Class.Session R.Table IO, StrictTVar IO Errors) -> IO ()
-    release (tmpDir, session, _) = do
+    release :: (FilePath, Class.Session R.Table IO, StrictTVar IO Errors) -> IO Property
+    release (tmpDir, !session, _) = do
+        !prop <- propNoThunks session
         R.closeSession session
         removeDirectoryRecursive tmpDir
+        pure prop
 
 propLockstep_RealImpl_MockFS_IO ::
      Tracer IO R.LSMTreeTrace
@@ -891,7 +893,6 @@ instance ( Eq (Class.TableConfig h)
          , Show (Class.TableConfig h)
          , Arbitrary (Class.TableConfig h)
          , Typeable h
-         , NoThunks (Class.Session h IO)
          ) => RunLockstep (ModelState h) (RealMonad h IO) where
   observeReal ::
        Proxy (RealMonad h IO)
@@ -1016,7 +1017,6 @@ instance ( Eq (Class.TableConfig h)
          , Show (Class.TableConfig h)
          , Arbitrary (Class.TableConfig h)
          , Typeable h
-         , NoThunks (Class.Session h IO)
          ) => RunModel (Lockstep (ModelState h)) (RealMonad h IO) where
   perform _     = runIO
   postcondition = Lockstep.Defaults.postcondition
@@ -1127,14 +1127,12 @@ wrap f = first (MEither . bimap MErr f)
 -------------------------------------------------------------------------------}
 
 runIO ::
-     forall a h. (Class.IsTable h, NoThunks (Class.Session h IO))
+     forall a h. Class.IsTable h
   => LockstepAction (ModelState h) a
   -> LookUp (RealMonad h IO)
   -> RealMonad h IO (Realized (RealMonad h IO) a)
 runIO action lookUp = ReaderT $ \ !env -> do
-    x <- aux env action
-    assertNoThunks (envSession env) $ pure ()
-    pure x
+    aux env action
   where
     aux ::
          RealEnv h IO