peer-metrics: use NoThunks in PeerMetrics

Use NoThunks library to verify that we don't have any unevaluated expressions in PeerMetric. This patch also makes PeerMetric more strict to satisfy the test. Apparently there was a small memory leak which goes away at every churn interval when we actually use peer metric in order to demote the 20% of worse performing peers.
IntersectMBO · Jul 27, 2023 · 3eed982 · 3eed982
1 parent 7a8bef8
commit 3eed982
Show file tree

Hide file tree

Showing 7 changed files with 63 additions and 41 deletions.
diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml
@@ -50,7 +50,7 @@ jobs:
 
     - name: "Configure cabal.project.local"
       run: |
-        cp .github/workflows/cabal.project.local.Windows cabal.project.local
+        cp .github/workflows/cabal.project.local cabal.project.local
 
     - name: Update PATH
       run: |

diff --git a/...hub/workflows/cabal.project.local.Windows → .github/workflows/cabal.project.local b/...hub/workflows/cabal.project.local.Windows → .github/workflows/cabal.project.local
@@ -4,6 +4,9 @@ ignore-project: False
 tests: True
 benchmarks: True
 
+package strict-stm
+  flags: +checktvarinvariant
+
 program-options
   ghc-options: -Werror
 
@@ -32,12 +35,3 @@ package network-mux
 
 package ouroboros-network
   flags: +ipv6 +cddl +asserts
-
-package HsOpenSSL
-  extra-include-dirs: D:/a/_temp/msys64/mingw64/include
-  extra-lib-dirs: D:/a/_temp/msys64/mingw64/lib
-  flags: +use-pkg-config
-
-package basement
-  extra-include-dirs: D:/a/_temp/msys64/mingw64/include
-  extra-lib-dirs: D:/a/_temp/msys64/mingw64/lib
diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md
@@ -6,6 +6,8 @@
 
 ### Non-breaking changes
 
+- Fixed a small memory leak in `PeerMetrics` (#4633).
+
 ## 0.8.2.0
 
 ### Breaking changes

diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal
@@ -124,7 +124,7 @@ library
                        ouroboros-network-api       ^>=0.5,
                        ouroboros-network-framework ^>=0.7,
                        ouroboros-network-protocols ^>=0.5.1.0,
-                       strict-stm,
+                       strict-stm                  ^>=1.1.0.1,
                        typed-protocols   >=0.1.0.4 && <1.0,
   if !os(windows)
     build-depends:     directory,

diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs
@@ -1,8 +1,13 @@
 {-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DerivingVia         #-}
+{-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving  #-}
 
 
 module Ouroboros.Network.PeerSelection.PeerMetric
@@ -41,6 +46,10 @@ import           Data.Maybe (fromMaybe)
 import           Data.Monoid (Sum (..))
 import           Data.OrdPSQ (OrdPSQ)
 import qualified Data.OrdPSQ as OrdPSQ
+import           GHC.Generics
+
+import           NoThunks.Class
+import           NoThunks.Class.Orphans () -- orphan instances
 
 import           Cardano.Slotting.Slot (SlotNo (..))
 import           Ouroboros.Network.DeltaQ (SizeInBytes)
@@ -56,6 +65,7 @@ newtype PeerMetricsConfiguration = PeerMetricsConfiguration {
       -- produced in one hour.
       maxEntriesToTrack :: Int
     }
+  deriving (Show, Generic, NoThunks)
 
 
 -- | Integer based metric ordered by 'SlotNo' which holds the peer and time.
@@ -111,6 +121,10 @@ data PeerMetricsState p = PeerMetricsState {
     --
     metricsConfig    :: !PeerMetricsConfiguration
   }
+  deriving Show
+  deriving Generic
+
+deriving instance NoThunks p => NoThunks (PeerMetricsState p)
 
 
 -- | Average results at a given slot.
@@ -120,31 +134,36 @@ data AverageMetrics = AverageMetrics {
     averageFetchynessBlocks :: !Int,
     averageFetchynessBytes  :: !Int
   }
-  deriving Show
+  deriving (Show, Generic, NoThunks)
 
 
 newPeerMetric
-    :: MonadSTM m
+    :: (MonadLabelledSTM m, NoThunks p)
     => PeerMetricsConfiguration
     -> m (PeerMetrics m p)
 newPeerMetric = newPeerMetric' IntPSQ.empty IntPSQ.empty
 
 
 newPeerMetric'
-    :: MonadSTM m
+    :: (MonadLabelledSTM m, NoThunks p)
     => SlotMetric p
     -> SlotMetric (p, SizeInBytes)
     -> PeerMetricsConfiguration
     -> m (PeerMetrics m p)
-newPeerMetric' headerMetrics fetchedMetrics metricsConfig =
-  PeerMetrics <$> newTVarIO PeerMetricsState {
-                                headerMetrics,
-                                fetchedMetrics,
-                                peerRegistry = OrdPSQ.empty,
-                                lastSeenRegistry = OrdPSQ.empty,
-                                lastSlotNo = SlotNo 0,
-                                metricsConfig
-                              }
+newPeerMetric' headerMetrics fetchedMetrics metricsConfig = atomically $ do
+
+  a <- newTVarWithInvariant
+    (\a -> show <$> unsafeNoThunks a)
+    PeerMetricsState {
+      headerMetrics,
+      fetchedMetrics,
+      peerRegistry     = OrdPSQ.empty,
+      lastSeenRegistry = OrdPSQ.empty,
+      lastSlotNo       = SlotNo 0,
+      metricsConfig
+    }
+  labelTVar a "peermetrics"
+  return (PeerMetrics a)
 
 updateLastSlot :: SlotNo -> PeerMetricsState p -> PeerMetricsState p
 updateLastSlot slotNo state@PeerMetricsState { lastSlotNo }
@@ -228,8 +247,8 @@ fetchedMetricTracer config peerMetrics@PeerMetrics{peerMetricsVar} =
     bimap remoteAddress (\(_, slotNo, _) -> slotNo)
     `contramap`
     peerRegistryTracer peerMetrics
- <> (\(TraceLabelPeer con (bytes, slot, time)) ->
-       TraceLabelPeer (remoteAddress con, bytes) (slot, time))
+ <> (\(TraceLabelPeer ConnectionId { remoteAddress } (!bytes, slot, time)) ->
+       TraceLabelPeer (remoteAddress, bytes) (slot, time))
     `contramap`
      metricsTracer
        (fetchedMetrics <$> readTVar peerMetricsVar)
@@ -357,9 +376,11 @@ metricsTracer
 metricsTracer getMetrics writeMetrics PeerMetricsConfiguration { maxEntriesToTrack } =
     Tracer $ \(TraceLabelPeer !peer (!slot, !time)) -> do
       metrics <- getMetrics
-      case IntPSQ.lookup (slotToInt slot) metrics of
+      let !k = slotToInt slot
+          !v = (peer, time)
+      case IntPSQ.lookup k metrics of
            Nothing -> do
-             let metrics' = IntPSQ.insert (slotToInt slot) slot (peer, time) metrics
+             let metrics' = IntPSQ.insert k slot v metrics
              if IntPSQ.size metrics' > maxEntriesToTrack
              -- drop last element if the metric board is too large
              then case IntPSQ.minView metrics' of
@@ -371,8 +392,7 @@ metricsTracer getMetrics writeMetrics PeerMetricsConfiguration { maxEntriesToTra
              else writeMetrics metrics'
            Just (_, (_, oldTime)) ->
                when (oldTime > time) $
-                    writeMetrics (IntPSQ.insert (slotToInt slot) slot
-                                                (peer, time) metrics)
+                    writeMetrics (IntPSQ.insert k slot v metrics)
 
 
 joinedPeerMetricAt

diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Policies.hs b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Policies.hs
@@ -6,7 +6,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
 
-
 module Test.Ouroboros.Network.Diffusion.Policies where
 
 import           Control.Concurrent.Class.MonadSTM.Strict
@@ -22,6 +21,8 @@ import           Data.Word
 import           Network.Socket (SockAddr (..))
 import           System.Random
 
+import           NoThunks.Class.Orphans ()
+
 import           Cardano.Slotting.Slot (SlotNo (..))
 import           Ouroboros.Network.Diffusion.Policies
 import           Ouroboros.Network.ExitPolicy (ReconnectDelay (..))
@@ -40,7 +41,6 @@ tests = testGroup "Policies"
   , testProperty "WarmToCold" prop_randomDemotion
   ]
 
-
 newtype ArbitrarySockAddr = ArbitrarySockAddr SockAddr deriving (Eq, Ord, Show)
 
 instance Arbitrary ArbitrarySockAddr where
@@ -137,13 +137,13 @@ instance Arbitrary ArbitraryPolicyArguments where
 
 
 prop_hotToWarm :: ArbitraryPolicyArguments
-                 -> Int
-                 -> Property
+               -> Int
+               -> Property
 prop_hotToWarm args seed = runSimOrThrow $ prop_hotToWarmM args seed
 
 -- Verify that there are no peers worse than the peers picked for demotion.
 prop_hotToWarmM :: forall m.
-                   ( MonadSTM m
+                   ( MonadLabelledSTM m
                    , Monad (STM m)
                    )
                  => ArbitraryPolicyArguments
@@ -210,7 +210,7 @@ prop_randomDemotion args seed = runSimOrThrow $ prop_randomDemotionM args seed
 -- Verifies that Tepid (formerly hot) or failing peers are more likely to get
 -- demoted/forgotten.
 prop_randomDemotionM :: forall m.
-                        ( MonadSTM m
+                        ( MonadLabelledSTM m
                         , Monad (STM m)
                         )
                      => ArbitraryPolicyArguments

diff --git a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs
@@ -1,7 +1,9 @@
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE NumericUnderscores  #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE NumericUnderscores         #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 
 module Test.Ouroboros.Network.PeerSelection.PeerMetric where
 
@@ -32,6 +34,8 @@ import           Cardano.Slotting.Slot (SlotNo (..))
 
 import           Control.Monad.IOSim
 
+import           NoThunks.Class
+
 import           Ouroboros.Network.Testing.Data.Script
 import           TestLib.Utils (AllProperty (..))
 
@@ -50,7 +54,8 @@ tests = testGroup "Ouroboros.Network.PeerSelection.PeerMetric"
 
 
 newtype TestAddress = TestAddress Int
-  deriving (Show, Eq, Ord)
+  deriving stock   (Show, Eq, Ord)
+  deriving newtype NoThunks
 
 instance Arbitrary TestAddress where
     arbitrary = do
@@ -147,13 +152,14 @@ data PeerMetricsTrace = PeerMetricsTrace {
     }
   deriving Show
 
-
 simulatePeerMetricScript
   :: forall m.
      ( MonadAsync m
      , MonadDelay m
      , MonadTimer m
      , MonadMonotonicTime m
+     , MonadLabelledSTM m
+     , MonadTraceSTM m
      )
   => Tracer m PeerMetricsTrace
   -> PeerMetricsConfiguration