eventlog: Add MEM_RETURN event to give information about fragmentation

See #19357

The event reports the
  * Current number of megablocks allocated
  * The number that the RTS thinks it needs
  * The number is managed to return to the OS

When current > need then the difference is returned to the OS, the
successful number of returned mblocks is reported by 'returned'.

In a fragmented heap current > need but returned < current - need.

8 files changed, 81 insertions, 3 deletions

diff --git a/rts/RtsProbes.d b/rts/RtsProbes.d
index efbe653e0b..e7b39e5a15 100644
--- a/rts/RtsProbes.d
+++ b/rts/RtsProbes.d
@@ -70,6 +70,7 @@ provider HaskellEvent {
   probe gc__done (EventCapNo);
   probe gc__global__sync (EventCapNo);
   probe gc__stats (EventCapsetID, StgWord, StgWord, StgWord, StgWord, StgWord, StgWord, StgWord, StgWord);
+  probe mem__return (StgWord, StgWord, StgWord);
   probe heap__info (EventCapsetID, StgWord, StgWord, StgWord, StgWord, StgWord);
   probe heap__allocated (EventCapNo, EventCapsetID, StgWord64);
   probe heap__size (EventCapsetID, StgWord);
diff --git a/rts/Trace.c b/rts/Trace.c
index 765617839e..d08b19a69d 100644
--- a/rts/Trace.c
+++ b/rts/Trace.c
@@ -41,6 +41,10 @@ int TRACE_cap;
 static Mutex trace_utx;
 #endif
 
+#if defined(DEBUG)
+static void traceCap_stderr(Capability *cap, char *msg, ...);
+#endif
+
 /* ---------------------------------------------------------------------------
    Starting up / shutting down the tracing facilities
  --------------------------------------------------------------------------- */
@@ -172,6 +176,7 @@ static char *thread_stop_reasons[] = {
 };
 #endif
 
+
 #if defined(DEBUG)
 static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag,
                                     StgTSO *tso,
@@ -369,6 +374,23 @@ void traceEventGcStats_  (Capability *cap,
     }
 }
 
+void traceEventMemReturn_ (Capability *cap,
+                          uint32_t    current_mblocks,
+                          uint32_t    needed_mblocks,
+                          uint32_t    returned_mblocks)
+{
+#if defined(DEBUG)
+    if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
+        traceCap_stderr(cap, "Memory Return (Current: %u) (Needed: %u) (Returned: %u)"
+                       , current_mblocks, needed_mblocks, returned_mblocks);
+    } else
+#endif
+    {
+        postEventMemReturn( cap, CAPSET_HEAP_DEFAULT
+                          , current_mblocks, needed_mblocks, returned_mblocks);
+    }
+}
+
 void traceCapEvent_ (Capability   *cap,
                      EventTypeNum  tag)
 {
diff --git a/rts/Trace.h b/rts/Trace.h
index f9d677d063..eed362e7b6 100644
--- a/rts/Trace.h
+++ b/rts/Trace.h
@@ -158,6 +158,11 @@ void traceEventGcStats_  (Capability *cap,
                           W_        par_tot_copied,
                           W_        par_balanced_copied);
 
+void traceEventMemReturn_  (Capability *cap,
+                          uint32_t    current_mblocks,
+                          uint32_t    needed_mblocks,
+                          uint32_t    returned_mblocks );
+
 /*
  * Record a spark event
  */
@@ -339,6 +344,7 @@ void flushTrace(void);
                            copied, slop, fragmentation, \
                            par_n_threads, par_max_copied, \
                            par_tot_copied, par_balanced_copied) /* nothing */
+#define traceEventMemReturn_(cap, current, needed, returned) /* nothing */
 #define traceHeapEvent(cap, tag, heap_capset, info1) /* nothing */
 #define traceEventHeapInfo_(heap_capset, gens, \
                             maxHeapSize, allocAreaSize, \
@@ -453,6 +459,8 @@ void dtraceUserMarkerWrapper(Capability *cap, char *msg);
                            par_max_copied,              \
                            par_balanced_copied,         \
                            par_tot_copied)
+#define dtraceEventMemReturn(current, needed, returned) \
+    HASKELLEVENT_MEM_RETURN(current, needed, returned)
 #define dtraceHeapInfo(heap_capset, gens,               \
                        maxHeapSize, allocAreaSize,      \
                        mblockSize, blockSize)           \
@@ -524,6 +532,7 @@ void dtraceUserMarkerWrapper(Capability *cap, char *msg);
                            par_max_copied,              \
                            par_tot_copied,              \
                            par_balanced_copied)         /* nothing */
+#define dtraceEventMemReturn(current, needed, returned) /* nothing */
 #define dtraceHeapInfo(heap_capset, gens,               \
                        maxHeapSize, allocAreaSize,      \
                        mblockSize, blockSize)           /* nothing */
@@ -743,6 +752,17 @@ INLINE_HEADER void traceEventGcStats(Capability *cap            STG_UNUSED,
                        par_tot_copied, par_balanced_copied);
 }
 
+INLINE_HEADER void traceEventMemReturn(Capability *cap            STG_UNUSED,
+                                     uint32_t    current_mblocks STG_UNUSED,
+                                     uint32_t    needed_mblocks  STG_UNUSED,
+                                     uint32_t    returned_mblocks STG_UNUSED)
+{
+    if (RTS_UNLIKELY(TRACE_gc)) {
+        traceEventMemReturn_(cap, current_mblocks, needed_mblocks, returned_mblocks);
+    }
+    dtraceEventMemReturn(current_mblocks, needed_mblocks, returned_mblocks);
+}
+
 INLINE_HEADER void traceEventHeapInfo(CapsetID    heap_capset   STG_UNUSED,
                                       uint32_t  gens          STG_UNUSED,
                                       W_        maxHeapSize   STG_UNUSED,
diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c
index 0a1ed09f6f..237c9bad9d 100644
--- a/rts/eventlog/EventLog.c
+++ b/rts/eventlog/EventLog.c
@@ -129,6 +129,7 @@ char *EventDesc[] = {
   [EVENT_REQUEST_PAR_GC]      = "Request parallel GC",
   [EVENT_GC_GLOBAL_SYNC]      = "Synchronise stop-the-world GC",
   [EVENT_GC_STATS_GHC]        = "GC statistics",
+  [EVENT_MEM_RETURN]          = "Memory return statistics",
   [EVENT_HEAP_INFO_GHC]       = "Heap static parameters",
   [EVENT_HEAP_ALLOCATED]      = "Total heap mem ever allocated",
   [EVENT_HEAP_SIZE]           = "Current heap size",
@@ -466,6 +467,11 @@ init_event_types(void)
                                + sizeof(StgWord32)
                                + sizeof(StgWord64) * 3;
             break;
+        case EVENT_MEM_RETURN:        // (heap_capset, current_mblocks
+                                      // , needed_mblocks, returned_mblocks)
+            eventTypes[t].size = sizeof(EventCapsetID)
+                               + sizeof(StgWord32) * 3;
+            break;
 
         case EVENT_TASK_CREATE:   // (taskId, cap, tid)
             eventTypes[t].size = sizeof(EventTaskId)
@@ -1159,6 +1165,22 @@ void postEventGcStats  (Capability    *cap,
     postWord64(eb, par_balanced_copied);
 }
 
+void postEventMemReturn  (Capability    *cap,
+                          EventCapsetID heap_capset,
+                          uint32_t current_mblocks,
+                          uint32_t needed_mblocks,
+                          uint32_t returned_mblocks)
+{
+    EventsBuf *eb = &capEventBuf[cap->no];
+    ensureRoomForEvent(eb, EVENT_MEM_RETURN);
+
+    postEventHeader(eb, EVENT_MEM_RETURN);
+    postCapsetID(eb, heap_capset);
+    postWord32(eb, current_mblocks);
+    postWord32(eb, needed_mblocks);
+    postWord32(eb, returned_mblocks);
+}
+
 void postTaskCreateEvent (EventTaskId taskId,
                           EventCapNo capno,
                           EventKernelThreadId tid)
diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h
index b0675db14d..9d3795f3ff 100644
--- a/rts/eventlog/EventLog.h
+++ b/rts/eventlog/EventLog.h
@@ -134,6 +134,13 @@ void postEventGcStats  (Capability    *cap,
                         W_           par_tot_copied,
                         W_           par_balanced_copied);
 
+void postEventMemReturn (Capability *cap,
+                        EventCapsetID  heap_capset,
+                         uint32_t current_mblocks,
+                         uint32_t needed_mblocks,
+                         uint32_t returned_mblocks
+                        );
+
 void postTaskCreateEvent (EventTaskId taskId,
                           EventCapNo cap,
                           EventKernelThreadId tid);
diff --git a/rts/sm/BlockAlloc.c b/rts/sm/BlockAlloc.c
index 451c182ac3..6e67f2cc8d 100644
--- a/rts/sm/BlockAlloc.c
+++ b/rts/sm/BlockAlloc.c
@@ -984,11 +984,14 @@ countAllocdBlocks(bdescr *bd)
     return n;
 }
 
-void returnMemoryToOS(uint32_t n /* megablocks */)
+// Returns the number of blocks which were able to be freed
+uint32_t returnMemoryToOS(uint32_t n /* megablocks */)
 {
     bdescr *bd;
     uint32_t node;
     StgWord size;
+    uint32_t init_n;
+    init_n = n;
 
     // ToDo: not fair, we free all the memory starting with node 0.
     for (node = 0; n > 0 && node < n_numa_nodes; node++) {
@@ -1028,6 +1031,7 @@ void returnMemoryToOS(uint32_t n /* megablocks */)
                        n);
         }
     );
+    return (init_n - n);
 }
 
 /* -----------------------------------------------------------------------------
diff --git a/rts/sm/BlockAlloc.h b/rts/sm/BlockAlloc.h
index 217d669a13..f28e35fc87 100644
--- a/rts/sm/BlockAlloc.h
+++ b/rts/sm/BlockAlloc.h
@@ -17,7 +17,7 @@ bdescr *allocLargeChunkOnNode (uint32_t node, W_ min, W_ max);
 
 extern W_ countBlocks       (bdescr *bd);
 extern W_ countAllocdBlocks (bdescr *bd);
-extern void returnMemoryToOS(uint32_t n);
+extern uint32_t returnMemoryToOS(uint32_t n);
 
 #if defined(DEBUG)
 void checkFreeListSanity(void);
diff --git a/rts/sm/GC.c b/rts/sm/GC.c
index 55e57a58b2..2911aad7a0 100644
--- a/rts/sm/GC.c
+++ b/rts/sm/GC.c
@@ -1004,9 +1004,11 @@ GarbageCollect (uint32_t collect_gen,
 
       got = mblocks_allocated;
 
+      uint32_t returned = 0;
       if (got > need) {
-          returnMemoryToOS(got - need);
+          returned = returnMemoryToOS(got - need);
       }
+      traceEventMemReturn(cap, got, need, returned);
   }
 
   // extra GC trace info