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.

1 files changed, 36 insertions, 0 deletions

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]
    ~~~~~~~~~~~~~~~~~~~~~