Fix several NoThunks issues (#1159)

fraser-iohk · web-flow · commit 468ec2401554 · 2024-07-09T17:34:53.000Z
# Description These changes fix several issues in which thunks are left unevaluated, triggering NoThunks errors in test suites when `checktvarinvariants` and `checkmvarinvariants` flags are enabled. - One of these changes adds a `force` into a test suite, but I'm not sure how happy we are with this solution -- it feels a bit pleasant (but we don't have a strict `List` anywhere convenient 😄) There are known NoThunks issues in our tests that are not fixed by these changes, but those issues are caused by other packages. It should also be noted that the behaviour of the NoThunks test runs differ between different compiler versions and optimization levels, so it may be difficult to reproduce detection of some of these uncaught unevaluated thunks. works towards fixing #560
diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal
@@ -275,6 +275,7 @@ test-suite consensus-test
     bytestring,
     cardano-crypto-class,
     cardano-slotting:{cardano-slotting, testlib},
+    cardano-strict-containers,
     containers,
     contra-tracer,
     directory,
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs
@@ -18,6 +18,7 @@ import           Data.List.NonEmpty (nonEmpty)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe)
+import           Data.Maybe.Strict (StrictMaybe (..))
 import           Data.Semigroup (Endo (..))
 import           Data.Set (Set, (\\))
 import qualified Data.Set as Set
@@ -141,7 +142,7 @@ prop_densityDisconnectStatic =
     mkState frag =
       ChainSyncState {
         csCandidate = frag,
-        csLatestSlot = Just (AF.headSlot frag),
+        csLatestSlot = SJust (AF.headSlot frag),
         csIdling = False
       }
     gen = do
@@ -377,7 +378,7 @@ evolveBranches EvolvingPeers {k, sgen, peers = initialPeers, fullTree} =
             ChainSyncState {
               csCandidate,
               csIdling = False,
-              csLatestSlot = Just (AF.headSlot csCandidate)
+              csLatestSlot = SJust (AF.headSlot csCandidate)
             }
         -- Run GDD.
         (loeFrag, suffixes) = sharedCandidatePrefix curChain candidates
diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Config.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Config.hs
@@ -5,6 +5,7 @@ module Test.Consensus.PeerSimulator.Config (defaultCfg) where
 import           Cardano.Crypto.DSIGN (SignKeyDSIGN (..), VerKeyDSIGN (..))
 import           Cardano.Slotting.Time (SlotLength, slotLengthFromSec)
 import qualified Data.Map.Strict as Map
+import           Data.Maybe.Strict (StrictMaybe (..))
 import           Ouroboros.Consensus.Config (SecurityParam, TopLevelConfig (..),
                      emptyCheckpointsMap)
 import           Ouroboros.Consensus.HardFork.History
@@ -39,7 +40,7 @@ defaultCfg secParam (ForecastRange sfor) sgen = TopLevelConfig {
       , (CoreId (CoreNodeId 1), VerKeyMockDSIGN 1)
       ]
     }
-  , topLevelConfigLedger      = TestBlockLedgerConfig eraParams (Just $ fromIntegral sfor)
+  , topLevelConfigLedger      = TestBlockLedgerConfig eraParams (SJust (fromIntegral sfor))
   , topLevelConfigBlock       = TestBlockConfig numCoreNodes
   , topLevelConfigCodec       = TestBlockCodecConfig
   , topLevelConfigStorage     = TestBlockStorageConfig
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Genesis/Governor.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Genesis/Governor.hs
@@ -37,7 +37,7 @@ module Ouroboros.Consensus.Genesis.Governor (
 import           Control.Monad (guard)
 import           Control.Tracer (Tracer, traceWith)
 import           Data.Containers.ListUtils (nubOrd)
-import           Data.Foldable (for_)
+import           Data.Foldable (for_, toList)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (maybeToList)
@@ -212,7 +212,7 @@ densityDisconnect (GenesisWindow sgen) (SecurityParam k) states candidateSuffixe
       state <- maybeToList (states Map.!? peer)
       -- Skip peers that haven't sent any headers yet.
       -- They should be disconnected by timeouts instead.
-      latestSlot <- maybeToList (csLatestSlot state)
+      latestSlot <- toList (csLatestSlot state)
       let candidateSuffix = candidateSuffixes Map.! peer
 
           idling = csIdling state
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs
@@ -80,6 +80,7 @@ import           Data.Kind (Type)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe)
+import           Data.Maybe.Strict (StrictMaybe (..))
 import           Data.Proxy
 import           Data.Typeable
 import           Data.Word (Word64)
@@ -349,7 +350,7 @@ bracketChainSyncClient
               csvSetCandidate =
               modifyTVar csHandleState . \ c s -> s {csCandidate = c}
             , csvSetLatestSlot =
-              modifyTVar csHandleState . \ ls s -> s {csLatestSlot = Just $! ls}
+              modifyTVar csHandleState . \ ls s -> s {csLatestSlot = SJust ls}
             , csvIdling = Idling {
                 idlingStart = atomically $ modifyTVar csHandleState $ \ s -> s {csIdling = True}
               , idlingStop = atomically $ modifyTVar csHandleState $ \ s -> s {csIdling = False}
@@ -365,7 +366,7 @@ bracketChainSyncClient
     mkChainSyncClientHandleState =
       newTVarIO ChainSyncState {
           csCandidate = AF.Empty AF.AnchorGenesis
-        , csLatestSlot = Nothing
+        , csLatestSlot = SNothing
         , csIdling = False
         }
 
@@ -1001,7 +1002,7 @@ findIntersectionTop cfgEnv dynEnv intEnv =
                 map castPoint
               $ AF.selectPoints (map fromIntegral offsets) ourFrag
 
-            uis = UnknownIntersectionState {
+            !uis = UnknownIntersectionState {
                 ourFrag               = ourFrag
               , ourHeaderStateHistory = ourHeaderStateHistory
               , uBestBlockNo
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs
@@ -167,6 +167,7 @@ import           Data.List (sortOn)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (catMaybes, fromMaybe)
+import           Data.Maybe.Strict (StrictMaybe (..))
 import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Block (HasHeader (getHeaderFields), Header,
                      Point (..), castPoint, pointSlot, succWithOrigin)
@@ -587,7 +588,7 @@ processJumpResult context jumpResult =
     updateChainSyncState handle jump = do
       let fragment = jTheirFragment jump
       modifyTVar (cschState handle) $ \csState ->
-        csState {csCandidate = fragment, csLatestSlot = Just (AF.headSlot fragment) }
+        csState {csCandidate = fragment, csLatestSlot = SJust (AF.headSlot fragment) }
       writeTVar (cschJumpInfo handle) $ Just jump
 
     mkGoodJumpInfo :: Maybe (JumpInfo blk) -> JumpInfo blk -> JumpInfo blk
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs
@@ -21,6 +21,7 @@ module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State (
 
 import           Cardano.Slotting.Slot (SlotNo, WithOrigin)
 import           Data.Function (on)
+import           Data.Maybe.Strict (StrictMaybe (..))
 import           Data.Typeable (Proxy (..), typeRep)
 import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Block (HasHeader, Header, Point)
@@ -56,7 +57,7 @@ data ChainSyncState blk = ChainSyncState {
     -- processing it further, and the latest slot may refer to a header beyond
     -- the forecast horizon while the candidate fragment isn't extended yet, to
     -- signal to GDD that the density is known up to this slot.
-  , csLatestSlot :: !(Maybe (WithOrigin SlotNo))
+  , csLatestSlot :: !(StrictMaybe (WithOrigin SlotNo))
   }
   deriving stock (Generic)
 
@@ -131,15 +132,15 @@ data ChainSyncJumpingState m blk
     -- honest, but the goal of the algorithm is to eventually have an honest,
     -- alert peer as dynamo.
     Dynamo
-      (DynamoInitState blk)
+      !(DynamoInitState blk)
       -- | The last slot at which we triggered jumps for the jumpers.
       !(WithOrigin SlotNo)
   | -- | The objector, of which there is at most one, also runs normal
     -- ChainSync. It is a former jumper that disagreed with the dynamo. When
     -- that happened, we spun it up to let normal ChainSync and Genesis decide
     -- which one to disconnect from.
     Objector
-      ObjectorInitState
+      !ObjectorInitState
       -- | The youngest point where the objector agrees with the dynamo.
       !(JumpInfo blk)
       -- | The point where the objector dissented with the dynamo when it was a
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs
@@ -887,7 +887,7 @@ data LoE a =
   -- When the selection's tip is @k@ blocks after the earliest intersection of
   -- of all candidate fragments, ChainSel will not add new blocks to the
   -- selection.
-  LoEEnabled a
+  LoEEnabled !a
   deriving (Eq, Show, Generic, NoThunks, Functor, Foldable, Traversable)
 
 type GetLoEFragment m blk = LoE (m (AnchoredFragment (Header blk)))
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
@@ -268,7 +268,7 @@ data ChainDbEnv m blk = CDB
     -- The number of blocks from the future is bounded by the number of
     -- upstream peers multiplied by the max clock skew divided by the slot
     -- length.
-  , cdbLoE             :: LoE (m (AnchoredFragment (Header blk)))
+  , cdbLoE             :: !(LoE (m (AnchoredFragment (Header blk))))
     -- ^ Configure the Limit on Eagerness. If this is 'LoEEnabled', it contains
     -- an action that returns the LoE fragment, which indicates the latest rollback
     -- point, i.e. we are not allowed to select a chain from which we could not
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs
@@ -97,6 +97,7 @@ import           Data.List.NonEmpty (NonEmpty (..), (<|))
 import           Data.Maybe (fromMaybe)
 import           Data.Set (Set)
 import qualified Data.Set as Set
+import           Data.Text (Text)
 import           Data.Void
 import           Data.Word (Word64)
 import           GHC.Generics (Generic)
@@ -414,11 +415,11 @@ electric :: m a -> Electric m a
 electric = Electric
 
 -- | A simple semaphore, though instead of blocking a fatal exception is thrown.
-data Fuse m = Fuse !String !(StrictMVar m ()) deriving (Generic)
+data Fuse m = Fuse !Text !(StrictMVar m ()) deriving (Generic)
 
 deriving instance NoThunks (StrictMVar m ()) => NoThunks (Fuse m)
 
-newFuse :: MonadMVar m => String -> m (Fuse m)
+newFuse :: MonadMVar m => Text -> m (Fuse m)
 newFuse name = Fuse name <$> newMVar ()
 
 -- | Put full load on the 'Fuse' while the 'Electric' is running.
@@ -446,6 +447,6 @@ withFuse (Fuse name m) (Electric io) = do
   pure a
 
 -- | Too much electrical load was put on the 'Fuse', see 'withFuse'.
-newtype FuseBlownException  = FuseBlownException  String
+newtype FuseBlownException = FuseBlownException Text
  deriving (Show)
  deriving anyclass (Exception)
diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/LeakyBucket.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/LeakyBucket.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns         #-}
 {-# LANGUAGE DeriveAnyClass       #-}
 {-# LANGUAGE DeriveGeneric        #-}
 {-# LANGUAGE FlexibleContexts     #-}
@@ -257,7 +258,7 @@ snapshotFill bucket toAdd = do
         levelFilled = min capacity (levelLeaked + toAdd)
         overflew = levelLeaked + toAdd > capacity
         newLevel = if not overflew || fillOnOverflow then levelFilled else levelLeaked
-        newState = State {time = newTime, level = newLevel, paused, config}
+        !newState = State {time = newTime, level = newLevel, paused, config}
     writeTVar bucket newState
     pure (newState, if overflew then Overflew else DidNotOverflow)
 
diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs
@@ -98,6 +98,7 @@ import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe)
+import           Data.Maybe.Strict (StrictMaybe (..), strictMaybeToMaybe)
 import           Data.Proxy
 import           Data.Time.Calendar (fromGregorian)
 import           Data.Time.Clock (UTCTime (..))
@@ -213,17 +214,17 @@ data Validity = Valid | Invalid
 -- instance. See the former class for more details.
 --
 data TestBlockWith ptype = TestBlockWith {
-      tbHash    :: TestHash
-    , tbSlot    :: SlotNo
+      tbHash    :: !TestHash
+    , tbSlot    :: !SlotNo
       -- ^ We store a separate 'Block.SlotNo', as slots can have gaps between
       -- them, unlike block numbers.
       --
       -- Note that when generating a 'TestBlock', you must make sure that
       -- blocks with the same 'TestHash' have the same slot number.
-    , tbValid   :: Validity
+    , tbValid   :: !Validity
       -- ^ Note that when generating a 'TestBlock', you must make sure that
       -- blocks with the same 'TestHash' have the same value for 'tbValid'.
-    , tbPayload :: ptype
+    , tbPayload :: !ptype
     }
   deriving stock    (Show, Eq, Ord, Generic)
   deriving anyclass (Serialise, NoThunks, ToExpr)
@@ -547,16 +548,16 @@ testInitExtLedgerWithState st = ExtLedgerState {
     }
 
 data TestBlockLedgerConfig = TestBlockLedgerConfig {
-  tblcHardForkParams :: HardFork.EraParams,
+  tblcHardForkParams :: !HardFork.EraParams,
   -- | `Nothing` means an infinite forecast range.
   -- Instead of SlotNo, it should be something like "SlotRange"
-  tblcForecastRange  :: Maybe SlotNo
+  tblcForecastRange  :: !(StrictMaybe SlotNo)
 }
   deriving (Show, Eq, Generic)
   deriving anyclass (NoThunks)
 
 testBlockLedgerConfigFrom :: HardFork.EraParams -> TestBlockLedgerConfig
-testBlockLedgerConfigFrom eraParams = TestBlockLedgerConfig eraParams Nothing
+testBlockLedgerConfigFrom eraParams = TestBlockLedgerConfig eraParams SNothing
 
 type instance LedgerCfg (LedgerState (TestBlockWith ptype)) = TestBlockLedgerConfig
 
@@ -592,7 +593,7 @@ instance (PayloadSemantics ptype) => ValidateEnvelope (TestBlockWith ptype) wher
 instance (PayloadSemantics ptype) => LedgerSupportsProtocol (TestBlockWith ptype) where
   protocolLedgerView   _ _  = ()
   ledgerViewForecastAt cfg state =
-    constantForecastInRange (tblcForecastRange cfg) () (getTipSlot state)
+    constantForecastInRange (strictMaybeToMaybe (tblcForecastRange cfg)) () (getTipSlot state)
 
 singleNodeTestConfigWith ::
      CodecConfig (TestBlockWith ptype)
@@ -624,7 +625,7 @@ singleNodeTestConfigWith codecConfig storageConfig k genesisWindow = TopLevelCon
     ledgerCfgParams :: TestBlockLedgerConfig
     ledgerCfgParams = TestBlockLedgerConfig {
       tblcHardForkParams = HardFork.defaultEraParams k slotLength,
-      tblcForecastRange = Nothing
+      tblcForecastRange = SNothing
     }
 
     _eraParams :: HardFork.EraParams
diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs
@@ -335,7 +335,7 @@ testOverrideDelay systemStart slotLength maxClockRewind numSlots = do
                       maxClockRewind)
       (\_btime   -> pure ())
       $ \btime   -> do
-      slotsVar <- newTVarIO []
+      slotsVar <- uncheckedNewTVarM []
       withWatcher
         "testOverrideDelay"
         ( knownSlotWatcher btime $ \slotNo -> do
