From 82d1a88dec216d761b17252ede760da5c566007f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=C3=96mer=20Sinan=20A=C4=9Facan?= <omeragacan@gmail.com>
Date: Thu, 10 Jan 2019 12:42:04 +0300
Subject: Implement a sanity check for CCS fields in profiling builds

This helped me debug one of the bugs in #15508. I'm not sure if this is
a good idea, but it worked for me, so wanted to submit this as a MR.
---
 rts/Arena.c     | 13 +++++++++++++
 rts/Arena.h     |  4 ++++
 rts/Profiling.c |  4 ++++
 rts/Profiling.h |  6 ++++++
 rts/sm/Sanity.c | 17 +++++++++++++++++
 5 files changed, 44 insertions(+)

diff --git a/rts/Arena.c b/rts/Arena.c
index cd547e5b33..e0b4ebde30 100644
--- a/rts/Arena.c
+++ b/rts/Arena.c
@@ -117,3 +117,16 @@ arenaBlocks( void )
 {
     return arena_blocks;
 }
+
+#if defined(DEBUG)
+void checkPtrInArena( StgPtr p, Arena *arena )
+{
+    for (bdescr *bd = arena->current; bd; bd = bd->link) {
+        if (p >= bd->start && p < bd->free) {
+            return;
+        }
+    }
+
+    barf("Location %p is not in arena %p", (void*)p, (void*)arena);
+}
+#endif
diff --git a/rts/Arena.h b/rts/Arena.h
index 8fa8236d8d..49298713ab 100644
--- a/rts/Arena.h
+++ b/rts/Arena.h
@@ -20,3 +20,7 @@ RTS_PRIVATE void arenaFree  ( Arena * );
 
 // For internal use only:
 RTS_PRIVATE unsigned long arenaBlocks( void );
+
+#if defined(DEBUG)
+void checkPtrInArena( StgPtr p, Arena *arena );
+#endif
diff --git a/rts/Profiling.c b/rts/Profiling.c
index 7abad59b1f..70bf3750e3 100644
--- a/rts/Profiling.c
+++ b/rts/Profiling.c
@@ -32,7 +32,11 @@
 /*
  * Profiling allocation arena.
  */
+#if defined(DEBUG)
+Arena *prof_arena;
+#else
 static Arena *prof_arena;
+#endif
 
 /*
  * Global variables used to assign unique IDs to cc's, ccs's, and
diff --git a/rts/Profiling.h b/rts/Profiling.h
index 45725e5631..c692c22b5e 100644
--- a/rts/Profiling.h
+++ b/rts/Profiling.h
@@ -13,6 +13,10 @@
 #include "BeginPrivate.h"
 #include "Rts.h"
 
+#if defined(DEBUG)
+#include "Arena.h"
+#endif
+
 #if defined(PROFILING)
 #define PROFILING_ONLY(s) s
 #else
@@ -46,6 +50,8 @@ bool ignoreCCS (CostCentreStack const *ccs);
 bool ignoreCC (CostCentre const *cc);
 
 #if defined(DEBUG)
+extern Arena *prof_arena;
+
 void debugCCS( CostCentreStack *ccs );
 #endif
 
diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c
index 1da3e4416f..28c9b432f8 100644
--- a/rts/sm/Sanity.c
+++ b/rts/sm/Sanity.c
@@ -29,6 +29,7 @@
 #include "Arena.h"
 #include "RetainerProfile.h"
 #include "CNF.h"
+#include "Profiling.h" // prof_arena
 
 /* -----------------------------------------------------------------------------
    Forward decls.
@@ -210,6 +211,17 @@ checkPAP (StgClosure *tagged_fun, StgClosure** payload, StgWord n_args)
            : GET_CLOSURE_TAG(tagged_fun) == fun_info->f.arity);
 }
 
+#if defined(PROFILING)
+static void
+checkClosureProfSanity(const StgClosure *p)
+{
+    StgProfHeader prof_hdr = p->header.prof;
+    CostCentreStack *ccs = prof_hdr.ccs;
+    if (HEAP_ALLOCED_GC((void*)ccs)) {
+        checkPtrInArena((StgPtr)ccs, prof_arena);
+    }
+}
+#endif
 
 StgOffset
 checkClosure( const StgClosure* p )
@@ -225,6 +237,11 @@ checkClosure( const StgClosure* p )
     if (IS_FORWARDING_PTR(info)) {
         barf("checkClosure: found EVACUATED closure %d", info->type);
     }
+
+#if defined(PROFILING)
+    checkClosureProfSanity(p);
+#endif
+
     info = INFO_PTR_TO_STRUCT(info);
 
     switch (info->type) {
-- 
cgit v1.2.1