rts: TraverseHeap: Add a basic test

For now this just tests that the order of the callbacks is what we expect
for a couple of synthetic heap graphs.

7 files changed, 307 insertions, 0 deletions

diff --git a/rts/TraverseHeap.c b/rts/TraverseHeap.c
index 8f8b62b2d0..40a70e2a50 100644
--- a/rts/TraverseHeap.c
+++ b/rts/TraverseHeap.c
@@ -16,6 +16,8 @@
 
 #include "TraverseHeap.h"
 
+const stackData nullStackData;
+
 StgWord getTravData(const StgClosure *c)
 {
     const StgWord hp_hdr = c->header.prof.hp.trav;
diff --git a/rts/TraverseHeap.h b/rts/TraverseHeap.h
index 8ea04dee32..0bc553e094 100644
--- a/rts/TraverseHeap.h
+++ b/rts/TraverseHeap.h
@@ -69,6 +69,8 @@ typedef union stackData_ {
     retainer c_child_r;
 } stackData;
 
+extern const stackData nullStackData;
+
 typedef union stackAccum_ {
     StgWord subtree_sizeW;
 } stackAccum;
diff --git a/rts/TraverseHeapTest.c b/rts/TraverseHeapTest.c
new file mode 100644
index 0000000000..9a71242e55
--- /dev/null
+++ b/rts/TraverseHeapTest.c
@@ -0,0 +1,219 @@
+
+#if defined(PROFILING) && defined(DEBUG)
+
+#include "PosixSource.h"
+#include <string.h>
+#include <Rts.h>
+#include <rts/storage/Closures.h>
+#include "TraverseHeap.h"
+
+#define container_of(ptr, type, member) ({                        \
+            const typeof( ((type *)0)->member ) *__mptr = (ptr);  \
+            (type *)( (char *)__mptr - offsetof(type,member) );})
+
+static StgInfoTable info_weak     = { .type = WEAK };
+static StgInfoTable info_selector = { .type = THUNK_SELECTOR };
+static StgInfoTable info_arrwords = { .type = ARR_WORDS };
+
+struct node {
+    unsigned int id;
+    union node_union {
+        StgClosure cls;
+        StgWeak weak;
+        StgSelector selector;
+        StgArrBytes arrbytes;
+    } u;
+};
+
+// See INFO_PTR_TO_STRUCT in ClosureMacros.h
+#if defined(TABLES_NEXT_TO_CODE)
+#define INFO(ptr) ((StgInfoTable *)ptr + 1)
+#else
+#define INFO(ptr) ((StgInfoTable *)ptr)
+#endif
+
+#define node3(_id, a,b,c)                               \
+    static struct node n##_id = {                       \
+        .id = _id,                                      \
+        .u.weak = {                                     \
+            .header = { .info = INFO(&info_weak) },     \
+            .key       = (StgClosure*)&(n##a.u),        \
+            .value     = (StgClosure*)&(n##b.u),        \
+            .finalizer = (StgClosure*)&(n##c.u),        \
+        }                                               \
+    };
+
+#define node1(_id, a)                                   \
+    static struct node n##_id = {                       \
+        .id = _id,                                      \
+        .u.selector = {                                 \
+            .header = { .info = INFO(&info_selector) }, \
+            .selectee = (StgClosure*)&(n##a.u),         \
+        }                                               \
+    }
+
+#define node0(_id)                                      \
+    static struct node n##_id = {                       \
+        .id = _id,                                      \
+        .u.arrbytes = {                                 \
+            .header = { .info = INFO(&info_arrwords) }, \
+        }                                               \
+    }
+
+
+/*
+ 1.0) Just a simple case to start with.
+
+   1
+  /
+ 0---2
+  \
+   3
+*/
+node0(1003);
+node0(1002);
+node0(1001);
+node3(1000,
+  1001,
+  1002,
+  1003);
+
+/*
+ 1.1) Now with a cycle
+
+   1
+  /` \,
+ 0--->2
+  \,
+   3
+*/
+node0(1103);
+node0(1102);
+node1(1101,
+  1102);
+node3(1100,
+  1101,
+  1102,
+  1103);
+
+/*
+ 2.0) This tests the chain optimization.
+
+   1     6
+  /     /
+ 0-2-4-5-7
+  \     \
+   3     8
+*/
+
+node0(2006);
+node0(2007);
+node0(2008);
+
+node3(2005,
+  2006,
+  2007,
+  2008);
+
+node1(2004,
+  2005);
+
+node0(2003);
+node1(2002,
+  2004);
+node0(2001);
+
+node3(2000,
+  2001,
+  2002,
+  2003);
+
+
+static void
+testReturn(StgClosure *c, const stackAccum acc,
+           StgClosure *c_parent, stackAccum *acc_parent)
+{
+    (void) acc;
+    (void) c_parent;
+    (void) acc_parent;
+
+    struct node *n = container_of(c, struct node, u.cls);
+
+    printf("return %u\n", n->id);
+
+    return;
+}
+
+static bool
+testVisit(StgClosure *c, const StgClosure *cp,
+          const stackData data, const bool first_visit,
+          stackAccum *acc, stackData *child_data)
+{
+    (void) cp;
+    (void) data;
+    (void) acc;
+    (void) child_data;
+
+    struct node *n = container_of(c, struct node, u.cls);
+
+    printf("visit  %u\n", n->id);
+
+    return first_visit;
+}
+
+static struct node* const g_tests[] = {
+    &n1000, &n1100,
+    &n2000,
+};
+
+static traverseState state;
+
+void traverseHeapRunTests(void);
+void traverseHeapRunTests(void)
+{
+    traverseState *ts = &state;
+
+    {
+        printf("with return\n");
+
+        state.return_cb = &testReturn;
+
+        initializeTraverseStack(ts);
+        traverseInvalidateClosureData(ts);
+
+        for(size_t i=0; i < (sizeof(g_tests)/sizeof(*g_tests)); i++) {
+            struct node *n = g_tests[i];
+
+            stackElement se;
+            memset(&se, 0, sizeof(se));
+
+            printf("\n\npush   %u\n", n->id);
+            traversePushClosure(ts, &n->u.cls, &n->u.cls, &se, nullStackData);
+            traverseWorkStack(ts, &testVisit);
+        }
+
+        closeTraverseStack(ts);
+    }
+
+    {
+        printf("\n\n\n\njust visit\n");
+
+        state.return_cb = NULL;
+
+        initializeTraverseStack(ts);
+        traverseInvalidateClosureData(ts);
+
+        for(size_t i=0; i < (sizeof(g_tests)/sizeof(*g_tests)); i++) {
+            struct node *n = g_tests[i];
+
+            printf("\n\npush   %u\n", n->id);
+            traversePushClosure(ts, &n->u.cls, &n->u.cls, NULL, nullStackData);
+            traverseWorkStack(ts, &testVisit);
+        }
+
+        closeTraverseStack(ts);
+
+    }
+}
+
+#endif
diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in
index ed727111ca..a1d0ce39a2 100644
--- a/rts/rts.cabal.in
+++ b/rts/rts.cabal.in
@@ -479,6 +479,7 @@ library
                TopHandler.c
                Trace.c
                TraverseHeap.c
+               TraverseHeapTest.c
                WSDeque.c
                Weak.c
                eventlog/EventLog.c
diff --git a/testsuite/tests/profiling/should_run/TraverseHeapTest.hs b/testsuite/tests/profiling/should_run/TraverseHeapTest.hs
new file mode 100644
index 0000000000..889c0c0bfc
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/TraverseHeapTest.hs
@@ -0,0 +1,4 @@
+foreign import ccall unsafe "traverseHeapRunTests" c_traverseHeapRunTests
+    :: IO ()
+
+main = c_traverseHeapRunTests
diff --git a/testsuite/tests/profiling/should_run/TraverseHeapTest.stdout b/testsuite/tests/profiling/should_run/TraverseHeapTest.stdout
new file mode 100644
index 0000000000..bd86ac8a1d
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/TraverseHeapTest.stdout
@@ -0,0 +1,77 @@
+with return
+
+
+push   1000
+visit  1000
+visit  1001
+return 1001
+visit  1002
+return 1002
+visit  1003
+return 1003
+return 1000
+
+
+push   1100
+visit  1100
+visit  1101
+visit  1102
+return 1102
+return 1101
+visit  1102
+visit  1103
+return 1103
+return 1100
+
+
+push   2000
+visit  2000
+visit  2001
+return 2001
+visit  2002
+visit  2004
+visit  2005
+visit  2006
+return 2006
+visit  2007
+return 2007
+visit  2008
+return 2008
+return 2005
+return 2004
+return 2002
+visit  2003
+return 2003
+return 2000
+
+
+
+
+just visit
+
+
+push   1000
+visit  1000
+visit  1001
+visit  1002
+visit  1003
+
+
+push   1100
+visit  1100
+visit  1101
+visit  1102
+visit  1102
+visit  1103
+
+
+push   2000
+visit  2000
+visit  2001
+visit  2002
+visit  2004
+visit  2005
+visit  2006
+visit  2007
+visit  2008
+visit  2003
diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T
index ad10baac13..fbe1379e92 100644
--- a/testsuite/tests/profiling/should_run/all.T
+++ b/testsuite/tests/profiling/should_run/all.T
@@ -150,3 +150,5 @@ test('T15897',
      makefile_test, ['T15897'])
 
 test('T17572', [], compile_and_run, [''])
+
+test('TraverseHeapTest', [only_ways(['prof'])], compile_and_run, ['-debug'])