Add strict-mvar dependency and StrictMVar with NoThunks invariants.

We depend on an unreleased version of `strict-mvar` and we create a new module for `StrictMVar`s with `NoThunks` invariants. We also add a flag `checkmvarnothunks` that acts as a switch for whether we want to run the invariant checks or not. By default, these checks are off, since we do not want to perform these checks in production.
IntersectMBO · May 29, 2023 · c9d1e4a · c9d1e4a
1 parent 20cef4d
commit c9d1e4a
Show file tree

Hide file tree

Showing 4 changed files with 83 additions and 0 deletions.
diff --git a/cabal.project b/cabal.project
@@ -77,3 +77,12 @@ package strict-stm
 
 package text-short
   flags: +asserts
+
+-- TODO: remove when a new version of strict-mvar is released
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/io-sim
+  tag: ec202298c420378ef90b3fc0126c39e0f52290a3
+  --sha256: 1p6pn83kwp66x2m0cw9a27blfcpmw0lrra72qd0pi5bj3v1bcrl9
+  subdir:
+    strict-mvar
diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -29,6 +29,12 @@ flag expose-sublibs
   manual:      True
   default:     False
 
+-- TODO: this is actually turning on invariant checks in general
+flag checkmvarnothunks
+  description: Enable runtime NoThunks checks on StrictMVars
+  manual:      True
+  default:     False
+
 common common-lib
   default-language: Haskell2010
   ghc-options:
@@ -41,6 +47,9 @@ common common-lib
     ghc-options: -fno-ignore-asserts
     cpp-options: -DENABLE_ASSERTIONS
 
+  if flag(checkmvarnothunks)
+    cpp-options: -DCHECK_MVAR_NOTHUNKS
+
 common common-test
   import:      common-lib
   ghc-options: -threaded -rtsopts
@@ -49,6 +58,7 @@ library
   import:           common-lib
   hs-source-dirs:   src/ouroboros-consensus
   exposed-modules:
+    Control.Concurrent.Class.MonadMVar.Strict.NoThunks
     Data.SOP.Counting
     Data.SOP.Functors
     Data.SOP.Index
@@ -321,6 +331,7 @@ library
     , si-timers                    ^>=1.1
     , sop-core                     >=0.5      && <0.6
     , streaming
+    , strict-mvar                  ^>=1.1
     , strict-stm                   ^>=1.1
     , text                         >=1.2      && <1.3
     , these                        >=1.1      && <1.2

diff --git a/...s-consensus/src/ouroboros-consensus/Control/Concurrent/Class/MonadMVar/Strict/NoThunks.hs b/...s-consensus/src/ouroboros-consensus/Control/Concurrent/Class/MonadMVar/Strict/NoThunks.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Control.Concurrent.Class.MonadMVar.Strict.NoThunks (
+    -- * StrictMVars with NoThunks invariants
+    newEmptyMVar
+  , newEmptyMVarWithInvariant
+  , newMVar
+  , newMVarWithInvariant
+    -- * Re-exports
+  , module StrictMVar
+  ) where
+
+#if CHECK_MVAR_NOTHUNKS
+import qualified Control.Concurrent.Class.MonadMVar.Strict.Checked as StrictMVar
+import           Control.Concurrent.Class.MonadMVar.Strict.Checked as StrictMVar hiding (newMVar, newMVarWithInvariant, newEmptyMVarWithInvariant, newEmptyMVar)
+#else
+import qualified Control.Concurrent.Class.MonadMVar.Strict as StrictMVar
+import           Control.Concurrent.Class.MonadMVar.Strict as StrictMVar hiding (newMVar, newMVarWithInvariant, newEmptyMVarWithInvariant, newEmptyMVar)
+#endif
+
+import           Control.Applicative ((<|>))
+import           NoThunks.Class (NoThunks (..), unsafeNoThunks)
+
+noThunksInvariant :: NoThunks a => a -> Maybe String
+noThunksInvariant = fmap show . unsafeNoThunks
+
+newMVar :: (MonadMVar m, NoThunks a) => a -> m (StrictMVar m a)
+newMVar = StrictMVar.newMVarWithInvariant noThunksInvariant
+
+newMVarWithInvariant ::
+     (MonadMVar m, NoThunks a)
+  => (a -> Maybe String)
+  -> a
+  -> m (StrictMVar m a)
+newMVarWithInvariant inv =
+    StrictMVar.newMVarWithInvariant (\x -> inv x <|> noThunksInvariant x)
+
+newEmptyMVar :: (MonadMVar m, NoThunks a) => m (StrictMVar m a)
+newEmptyMVar = StrictMVar.newEmptyMVarWithInvariant noThunksInvariant
+
+newEmptyMVarWithInvariant ::
+     (MonadMVar m, NoThunks a)
+  => (a -> Maybe String)
+  -> m (StrictMVar m a)
+newEmptyMVarWithInvariant inv =
+    StrictMVar.newEmptyMVarWithInvariant (\x -> inv x <|> noThunksInvariant x)
+
+instance NoThunks a => NoThunks (StrictMVar IO a) where
+  showTypeOf _ = "StrictMVar IO"
+  wNoThunks ctxt mvar = do
+      a <- StrictMVar.readMVar mvar
+      noThunks ctxt a
diff --git a/scripts/ci/run-stylish.sh b/scripts/ci/run-stylish.sh
@@ -11,6 +11,7 @@ fd -p $(pwd)/ouroboros-consensus \
     -e hs \
     -E Setup.hs \
     -E ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs \
+    -E ouroboros-consensus/src/ouroboros-consensus/Control/Concurrent/Class/MonadMVar/Strict/NoThunks.hs \
     -X stylish-haskell \
     -c .stylish-haskell.yaml -i
 
@@ -19,3 +20,10 @@ fd -p $(pwd)/ouroboros-consensus \
 grep "#if __GLASGOW_HASKELL__ < 900
 import           Data.Foldable (asum)
 #endif" ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs                           >/dev/null 2>&1
+grep "#if CHECK_MVAR_NOTHUNKS
+import qualified Control.Concurrent.Class.MonadMVar.Strict.Checked as StrictMVar
+import           Control.Concurrent.Class.MonadMVar.Strict.Checked as StrictMVar hiding (newMVar, newMVarWithInvariant, newEmptyMVarWithInvariant, newEmptyMVar)
+#else
+import qualified Control.Concurrent.Class.MonadMVar.Strict as StrictMVar
+import           Control.Concurrent.Class.MonadMVar.Strict as StrictMVar hiding (newMVar, newMVarWithInvariant, newEmptyMVarWithInvariant, newEmptyMVar)
+#endif" ouroboros-consensus/src/ouroboros-consensus/Control/Concurrent/Class/MonadMVar/Strict/NoThunks.hs >/dev/null 2>&1