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.

10 files changed, 106 insertions, 6 deletions

diff --git a/docs/users_guide/eventlog-formats.rst b/docs/users_guide/eventlog-formats.rst
index 9ccd6bb2cf..f8561a911d 100644
--- a/docs/users_guide/eventlog-formats.rst
+++ b/docs/users_guide/eventlog-formats.rst
@@ -258,6 +258,10 @@ A typical garbage collection will look something like the following:
 13. As mutator threads resume execution they will emit :event-type:`RUN_THREAD`
     events.
 
+14. A :event-type:`MEM_RETURN` event will be emitted containing details about
+    currently live mblocks, how many we think we need and whether we could return
+    excess to the OS.
+
 Note that in the case of the concurrent non-moving collector additional events
 will be emitted during the concurrent phase of collection. These are described
 in :ref:`nonmoving-gc-events`.
@@ -319,13 +323,14 @@ in :ref:`nonmoving-gc-events`.
    :field Word16: generation of collection
    :field Word64: bytes copied
    :field Word64: bytes of slop found
-   :field Word64: TODO
+   :field Word64: bytes of fragmentation, the difference between total mblock size
+                  and total block size. When all mblocks are full of full blocks,
+                  this number is 0.
    :field Word64: number of parallel garbage collection threads
    :field Word64: maximum number of bytes copied by any single collector thread
    :field Word64: total bytes copied by all collector threads
 
-   Report various information about the heap configuration. Typically produced
-   during RTS initialization..
+   Report various information about a major collection.
 
 .. event-type:: GC_GLOBAL_SYNC
 
@@ -334,6 +339,21 @@ in :ref:`nonmoving-gc-events`.
 
    TODO
 
+.. event-type:: MEM_RETURN
+
+   :tag: 90
+   :length: fixed
+   :field CapSetId: heap capability set
+   :field Word32: currently allocated mblocks
+   :field Word32: the number of mblocks we would like to retain
+   :field Word32: the number of mblocks which we returned to the OS
+
+   Report information about currently allocation megablocks and attempts
+   made to return them to the operating system. If your heap is fragmented
+   then the current value will be greater than needed value but returned will
+   be less than the difference between the two.
+
+
 Heap events and statistics
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 
diff --git a/includes/rts/EventLogFormat.h b/includes/rts/EventLogFormat.h
index b80a9d3a94..37b7bc363d 100644
--- a/includes/rts/EventLogFormat.h
+++ b/includes/rts/EventLogFormat.h
@@ -127,6 +127,8 @@
  * see http://www.mathematik.uni-marburg.de/~eden/
  */
 
+#define EVENT_MEM_RETURN         90 /* (cap, current_mblocks, needed_mblocks, returned_mblocks) */
+
 /* Range 100 - 139 is reserved for Mercury. */
 
 /* Range 140 - 159 is reserved for Perf events. */
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