Merge pull request #4620 from input-output-hk/coot/strict-peer-metric

Improve memory footprint of peer metric
IntersectMBO · Jul 17, 2023 · 5553ebe · 5553ebe
2 parents ff47da1 + 3f92c57
commit 5553ebe
Show file tree

Hide file tree

Showing 2 changed files with 15 additions and 18 deletions.
diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md
@@ -18,6 +18,7 @@
 * Limit concurrency used by dns resolution.  We only resolve up to 8 dns names
   concurrently for public / ledger peers and up to 2 for local root peers.
   This will affect how quickly node connects to ledger peers when it starts.
+* Improved memory footprint of peer metrics (#4620)
 
 ## 0.8.1.1
 

diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs
@@ -85,31 +85,31 @@ data PeerMetricsState p = PeerMetricsState {
 
     -- | Header metrics.
     --
-    headerMetrics    :: SlotMetric p,
+    headerMetrics    :: !(SlotMetric p),
 
     -- | Fetch metrics.
     --
-    fetchedMetrics   :: SlotMetric (p, SizeInBytes),
+    fetchedMetrics   :: !(SlotMetric (p, SizeInBytes)),
 
     -- | Registry recording when a peer joined the board of 'PeerMetrics'.  The
     -- values are average header and fetched metrics.
     --
-    peerRegistry     :: PeerRegistry p,
+    peerRegistry     :: !(PeerRegistry p),
 
     -- | A registry which indicates when the last time a peer was seen.
     --
     -- If a peer hasn't been seen since the oldest recorded slot number, it will
     -- be removed.
     --
-    lastSeenRegistry :: LastSeenRegistry p,
+    lastSeenRegistry :: !(LastSeenRegistry p),
 
     -- | Latest slot registered in the leader board.
     --
-    lastSlotNo       :: SlotNo,
+    lastSlotNo       :: !SlotNo,
 
     -- | Metrics configuration.  Its kept here just for convenience.
     --
-    metricsConfig    :: PeerMetricsConfiguration
+    metricsConfig    :: !PeerMetricsConfiguration
   }
 
 
@@ -260,27 +260,23 @@ insertPeer :: forall p. Ord p
            -> SlotNo -- ^ current slot
            -> PeerMetricsState p
            -> PeerMetricsState p
-insertPeer p slotNo
+insertPeer p !slotNo
            peerMetricsState@PeerMetricsState { lastSeenRegistry, peerRegistry } =
     if p `OrdPSQ.member` lastSeenRegistry
     then peerMetricsState
     else case OrdPSQ.alter f p peerRegistry of
-           (False,  peerRegistry') -> peerMetricsState { peerRegistry = peerRegistry' }
+           (False, !peerRegistry') -> peerMetricsState { peerRegistry = peerRegistry' }
            (True,  _peerRegistry') -> peerMetricsState
   where
     f :: Maybe (SlotNo, AverageMetrics) -> (Bool, Maybe (SlotNo, AverageMetrics))
     f a@Just {} = (True,  a)
-    f Nothing   = (False, Just ( slotNo
-                               , AverageMetrics {
-                                     averageUpstreamyness    = avg upstreamenessResults,
-                                     averageFetchynessBytes  = avg fetchynessBytesResults,
-                                     averageFetchynessBlocks = avg fetchynessBlocksResults
-                                   }
-                               ))
+    f Nothing   = (False, Just $! (slotNo, metrics))
       where
-        upstreamenessResults    = upstreamynessImpl    peerMetricsState
-        fetchynessBytesResults  = fetchynessBytesImpl  peerMetricsState
-        fetchynessBlocksResults = fetchynessBlocksImpl peerMetricsState
+        !metrics = AverageMetrics {
+                     averageUpstreamyness    = avg (upstreamynessImpl    peerMetricsState),
+                     averageFetchynessBytes  = avg (fetchynessBytesImpl  peerMetricsState),
+                     averageFetchynessBlocks = avg (fetchynessBlocksImpl peerMetricsState)
+                   }
 
     avg :: Map p Int -> Int
     avg m | Map.null m = 0