rts: Add generic block traversal function, listAllBlocks

This function is exposed in the RtsAPI.h so that external users have a
blessed way to traverse all the different `bdescr`s which are known by
the RTS.

The main motivation is to use this function in ghc-debug but avoid
having to expose the internal structure of a Capability in the API.

2 files changed, 39 insertions, 0 deletions

diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h
index 6bc7157bd6..6acfd10cea 100644
--- a/includes/rts/storage/GC.h
+++ b/includes/rts/storage/GC.h
@@ -163,6 +163,9 @@ extern generation * generations;
 extern generation * g0;
 extern generation * oldest_gen;
 
+typedef void(*ListBlocksCb)(void *user, bdescr *);
+void listAllBlocks(ListBlocksCb cb, void *user);
+
 /* -----------------------------------------------------------------------------
    Generic allocation
 
diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c
index 41abbfc81c..2bab2d6432 100644
--- a/rts/sm/Storage.c
+++ b/rts/sm/Storage.c
@@ -321,6 +321,42 @@ freeStorage (bool free_heap)
     freeGcThreads();
 }
 
+static void
+listGenBlocks (ListBlocksCb cb, void *user, generation* gen)
+{
+    cb(user, gen->blocks);
+    cb(user, gen->large_objects);
+    cb(user, gen->compact_objects);
+    cb(user, gen->compact_blocks_in_import);
+}
+
+// Traverse all the different places that the rts stores blocks
+// and call a callback on each of them.
+void listAllBlocks (ListBlocksCb cb, void *user)
+{
+  uint32_t g, i;
+  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+      for (i = 0; i < n_capabilities; i++) {
+          cb(user, capabilities[i]->mut_lists[g]);
+          cb(user, gc_threads[i]->gens[g].part_list);
+          cb(user, gc_threads[i]->gens[g].scavd_list);
+          cb(user, gc_threads[i]->gens[g].todo_bd);
+      }
+      listGenBlocks(cb, user, &generations[g]);
+  }
+
+  for (i = 0; i < n_nurseries; i++) {
+      cb(user, nurseries[i].blocks);
+  }
+  for (i = 0; i < n_capabilities; i++) {
+      if (capabilities[i]->pinned_object_block != NULL) {
+          cb(user, capabilities[i]->pinned_object_block);
+      }
+      cb(user, capabilities[i]->pinned_object_blocks);
+  }
+}
+
+
 /* -----------------------------------------------------------------------------
    Note [CAF management]
    ~~~~~~~~~~~~~~~~~~~~~