Merge pull request #479 from IntersectMBO/jdral/344

Re-enable NoThunks tests (#444)

Author: jorisdral

lsm-tree.cabal

@@ -320,6 +320,7 @@ library extras
     , contra-tracer
     , deepseq
     , fs-api
+    , fs-sim
     , io-classes:strict-mvar
     , io-classes:strict-stm
     , lsm-tree

src-extras/Database/LSMTree/Extras/NoThunks.hs

@@ -68,6 +68,8 @@ import           KMerge.Heap
 import           NoThunks.Class
 import           System.FS.API
 import           System.FS.BlockIO.API
+import           System.FS.IO
+import           System.FS.Sim.MockFS
 import           Test.QuickCheck (Property, Testable (..), counterexample)
 import           Unsafe.Coerce
 
@@ -542,7 +544,7 @@ instance (NoThunks a, Typeable s, Typeable a) => NoThunks (MutableHeap s a) wher
 -- a)@, can not be satisfied for arbitrary @m@\/@s@, and must be instantiated
 -- for a concrete @m@\/@s@, like @IO@\/@RealWorld@.
 class ( forall a. NoThunks a => NoThunks (StrictTVar m a)
-      , forall a. NoThunks a => NoThunks (StrictMVar m a)
+      , forall a. (NoThunks a, Typeable a) => NoThunks (StrictMVar m a)
       ) => NoThunksIOLike' m s
 
 instance NoThunksIOLike' IO RealWorld
@@ -564,11 +566,37 @@ instance NoThunks a => NoThunks (StrictTVar IO a) where
 #endif
 #endif
 
-instance NoThunks a => NoThunks (StrictMVar IO a) where
-  showTypeOf (_ :: Proxy (StrictMVar IO a)) = "StrictMVar IO"
-  wNoThunks ctx var = do
-      x <- readMVar var
-      noThunks ctx x
+-- TODO: in some cases, strict-mvar functions leave thunks behind, in particular
+-- modifyMVarMasked and modifyMVarMasked_. So in some specific cases we evaluate
+-- the contents of the MVar to WHNF, and keep checking nothunks from there. See
+-- lsm-tree#444.
+--
+-- TODO: we tried using overlapping instances for @StrictMVar IO a@ and
+-- @StrictMVar IO (MergingRunState IO h)@, but the quantified constraint in
+-- NoThunksIOLike' will throw a compiler error telling us to mark the instances
+-- for StrictMVar as incoherent. Marking them as incoherent makes the tests
+-- fail... We are unsure if it can be overcome, but the current casting approach
+-- works, so there is no priority to use rewrite this code to use overlapping
+-- instances.
+instance (NoThunks a, Typeable a) => NoThunks (StrictMVar IO a) where
+  showTypeOf (p :: Proxy (StrictMVar IO a)) = show $ typeRep p
+  wNoThunks ctx var
+    | Just (Proxy :: Proxy (MergingRunState IO HandleIO))
+        <- gcast (Proxy @a)
+    = workAroundCheck
+    | Just (Proxy :: Proxy (MergingRunState IO HandleMock))
+        <- gcast (Proxy @a)
+    = workAroundCheck
+    | otherwise
+    = properCheck
+    where
+      properCheck = do
+        x <- readMVar var
+        noThunks ctx x
+
+      workAroundCheck = do
+        !x <- readMVar var
+        noThunks ctx x
 
 {-------------------------------------------------------------------------------
   vector

test/Test/Database/LSMTree/Normal/StateMachine.hs

@@ -957,8 +957,7 @@ runIO action lookUp = ReaderT $ \(session, handler) -> do
     x <- aux (unwrapSession session) handler action
     case session of
       WrapSession sesh ->
-        -- TODO: Re-enable NoThunks assertions. See lsm-tree#444.
-        const id (assertNoThunks sesh) $ pure ()
+        assertNoThunks sesh $ pure ()
     pure x
   where
     aux ::

test/Test/Database/LSMTree/Normal/StateMachine/DL.hs

@@ -20,16 +20,14 @@ import qualified Test.QuickCheck.Gen as QC
 import qualified Test.QuickCheck.Random as QC
 import           Test.QuickCheck.StateModel.Lockstep
 import           Test.Tasty (TestTree, testGroup)
+import qualified Test.Tasty.QuickCheck as QC
 import           Test.Util.PrettyProxy
 
 tests :: TestTree
 tests = testGroup "Test.Database.LSMTree.Normal.StateMachine.DL" [
-   -- This one is not actually enabled, because it runs for rather a long time
-   -- and it's not in itself a very import property.
-   -- QC.testProperty "prop_example" prop_example
+
+      QC.testProperty "prop_example" prop_example
     ]
-  where
-    _unused = prop_example
 
 instance DynLogicModel (Lockstep (ModelState R.Table))
 
@@ -52,22 +50,21 @@ prop_example =
     -- instead
     tr = nullTracer
 
--- | Create an initial "large" table, and then proceed with random actions as
--- usual.
+-- | Create an initial "large" table
 dl_example :: DL (Lockstep (ModelState R.Table)) ()
 dl_example = do
     -- Create an initial table and fill it with some inserts
     var3 <- action $ New (PrettyProxy @((Key, Value, Blob))) (TableConfig {
           confMergePolicy = MergePolicyLazyLevelling
         , confSizeRatio = Four
-        , confWriteBufferAlloc = AllocNumEntries (NumEntries 30)
+        , confWriteBufferAlloc = AllocNumEntries (NumEntries 4)
         , confBloomFilterAlloc = AllocFixed 10
         , confFencePointerIndex = CompactIndex
         , confDiskCachePolicy = DiskCacheNone
         , confMergeSchedule = OneShot })
     let kvs :: Map.Map Key Value
         kvs = Map.fromList $
-              QC.unGen (QC.vectorOf 678 $ (,) <$> QC.arbitrary <*> QC.arbitrary)
+              QC.unGen (QC.vectorOf 37 $ (,) <$> QC.arbitrary <*> QC.arbitrary)
                        (QC.mkQCGen 42) 30
         ups :: V.Vector (Key, Update Value Blob)
         ups = V.fromList
@@ -84,5 +81,3 @@ dl_example = do
             | Just tbl <- (Model.fromSomeTable @Key @Value @Blob smTbl)
             -> Map.size (Model.values tbl) == Map.size kvs
           _ -> False
-    -- Perform any sequence of actions after
-    anyActions_