rts: Implement ghc-debug API

There are four components to this patch which make it possible to
implement `ghc-debug`.

1. Add four new functions to the RtsAPI.
  * rts_pause and rts_unpause allow an external process to completely
  pause and unpause the RTS.
  * rts_listThreads and rts_listMiscRoots are used to find the current
  roots of the garbage collector.

These changes also mean that `Task.h` is exposed to the user.

2. Generalise the `ghc-heap` API so that raw `Word`s can be returned
rather than actual objects. This is necessary when trying to decode
closures on an external process because the pointers in such closures
are correct for the internal rather than external process. If you used
the previous API then you would get a segfault as the garbage collector
would try to traverse into these nonsensical branches.

```
-- before
getClosureData :: a -> IO Closure
-- after
getClosureDataX :: (forall c . c -> IO (Ptr StgInfoTable, [Word], [b]))
	                      -> a -> IO (GenClosure b)
```

For the normal case `b` is instantiated to `Box`, which contains a
pointer to a heap object.

```
data Box = Box a

-- GenClosure Box
```

For `ghc-debug` we instead just take the word of the address as we have
to explicitly interpret it on the external process.

```
GenClosure Word
```

3. Support for decoding `TSO` and `STACK` closures is partially
implemented. There is still quite a bit of work to do to finish both but
these at least allow us to make some more progress.

4. findPtr is generalised to take a callback argument. This means that
its result can be communicated to the debugger rather than just printing
out the result. The debugger has a function which invokes `findPtr` and
passes a callback which sends the result over a socket.

Co-authored-by: Ben Gamari <ben@smart-cactus.org>

13 files changed, 326 insertions, 90 deletions

diff --git a/includes/Rts.h b/includes/Rts.h
index d0f5371007..be5dc0331d 100644
--- a/includes/Rts.h
+++ b/includes/Rts.h
@@ -221,6 +221,7 @@ void _assertFail(const char *filename, unsigned int linenum)
 #include "rts/Globals.h"
 #include "rts/IOManager.h"
 #include "rts/Linker.h"
+#include "rts/Task.h"
 #include "rts/Ticky.h"
 #include "rts/Timer.h"
 #include "rts/StablePtr.h"
diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
index 488cab5f3f..6ab7116a7c 100644
--- a/includes/RtsAPI.h
+++ b/includes/RtsAPI.h
@@ -16,7 +16,9 @@ extern "C" {
 #endif
 
 #include "HsFFI.h"
+#include "rts/Types.h"
 #include "rts/Time.h"
+#include "rts/Task.h"
 #include "rts/EventLogWriter.h"
 
 /*
@@ -444,6 +446,24 @@ void rts_checkSchedStatus (char* site, Capability *);
 
 SchedulerStatus rts_getSchedStatus (Capability *cap);
 
+// Various bits of information that need to be persisted between rts_pause and
+// rts_unpause.
+typedef struct RtsPaused_ {
+    Task *pausing_task;
+    Capability *capabilities;
+} RtsPaused;
+
+RtsPaused rts_pause (void);
+void rts_unpause (RtsPaused paused);
+
+// List all live threads. Must be done while RTS is paused.
+typedef void (*ListThreadsCb)(void *user, StgTSO *);
+void rts_listThreads(ListThreadsCb cb, void *user);
+
+// List all non-thread GC roots. Must be done while RTS is paused.
+typedef void (*ListRootsCb)(void *user, StgClosure *);
+void rts_listMiscRoots(ListRootsCb cb, void *user);
+
 /*
  * The RTS allocates some thread-local data when you make a call into
  * Haskell using one of the rts_eval() functions.  This data is not
diff --git a/includes/rts/Task.h b/includes/rts/Task.h
new file mode 100644
index 0000000000..d8fe440823
--- /dev/null
+++ b/includes/rts/Task.h
@@ -0,0 +1,40 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Task API
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+typedef struct Task_ Task;
+
+// Create a new Task for a bound thread.  This Task must be released
+// by calling boundTaskExiting.  The Task is cached in
+// thread-local storage and will remain even after boundTaskExiting()
+// has been called; to free the memory, see freeMyTask().
+//
+Task* newBoundTask (void);
+
+// Return the current OS thread's Task, which is created if it doesn't already
+// exist.  After you have finished using RTS APIs, you should call freeMyTask()
+// to release this thread's Task.
+Task* getTask (void);
+
+// The current task is a bound task that is exiting.
+//
+void boundTaskExiting (Task *task);
+
+// Free a Task if one was previously allocated by newBoundTask().
+// This is not necessary unless the thread that called newBoundTask()
+// will be exiting, or if this thread has finished calling Haskell
+// functions.
+//
+void freeMyTask(void);
+
diff --git a/includes/rts/storage/Heap.h b/includes/rts/storage/Heap.h
index 2e908279bf..749882bfdc 100644
--- a/includes/rts/storage/Heap.h
+++ b/includes/rts/storage/Heap.h
@@ -11,6 +11,7 @@
 #include "rts/storage/Closures.h"
 
 StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure);
+StgArrBytes *heap_view_closurePtrsAsWords(Capability *cap, StgClosure *closure);
 
 void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs
                         , StgClosure *fun, StgClosure **payload, StgWord size);
diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs
index 4865dd60c9..36762b28f3 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap.hs
@@ -7,6 +7,8 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeInType #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE RankNTypes #-}
 
 {-|
 Module      :  GHC.Exts.Heap
@@ -24,7 +26,8 @@ module GHC.Exts.Heap (
     , GenClosure(..)
     , ClosureType(..)
     , PrimType(..)
-    , HasHeapRep(getClosureData)
+    , HasHeapRep(getClosureDataX)
+    , getClosureData
 
     -- * Info Table types
     , StgInfoTable(..)
@@ -66,75 +69,80 @@ import GHC.Word
 #include "ghcconfig.h"
 
 class HasHeapRep (a :: TYPE rep) where
-    getClosureData :: a -> IO Closure
+    getClosureDataX :: (forall c . c -> IO (Ptr StgInfoTable, [Word], [b]))
+                      -> a -> IO (GenClosure b)
 
 instance HasHeapRep (a :: TYPE 'LiftedRep) where
-    getClosureData = getClosure
+    getClosureDataX = getClosureX
 
 instance HasHeapRep (a :: TYPE 'UnliftedRep) where
-    getClosureData x = getClosure (unsafeCoerce# x)
+    getClosureDataX k x = getClosureX (k . unsafeCoerce#) (unsafeCoerce# x)
 
 instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where
-    getClosureData x = return $
+    getClosureDataX _ x = return $
         IntClosure { ptipe = PInt, intVal = I# x }
 
 instance Word# ~ a => HasHeapRep (a :: TYPE 'WordRep) where
-    getClosureData x = return $
+    getClosureDataX _ x = return $
         WordClosure { ptipe = PWord, wordVal = W# x }
 
 instance Int64# ~ a => HasHeapRep (a :: TYPE 'Int64Rep) where
-    getClosureData x = return $
+    getClosureDataX _ x = return $
         Int64Closure { ptipe = PInt64, int64Val = I64# (unsafeCoerce# x) }
 
 instance Word64# ~ a => HasHeapRep (a :: TYPE 'Word64Rep) where
-    getClosureData x = return $
+    getClosureDataX _ x = return $
         Word64Closure { ptipe = PWord64, word64Val = W64# (unsafeCoerce# x) }
 
 instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where
-    getClosureData x = return $
+    getClosureDataX _ x = return $
         AddrClosure { ptipe = PAddr, addrVal = I# (unsafeCoerce# x) }
 
 instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where
-    getClosureData x = return $
+    getClosureDataX _ x = return $
         FloatClosure { ptipe = PFloat, floatVal = F# x }
 
 instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
-    getClosureData x = return $
+    getClosureDataX _ x = return $
         DoubleClosure { ptipe = PDouble, doubleVal = D# x }
 
--- | This returns the raw representation of the given argument. The second
--- component of the triple is the raw words of the closure on the heap, and the
--- third component is those words that are actually pointers. Once back in the
--- Haskell world, the raw words that hold pointers may be outdated after a
--- garbage collector run, but the corresponding values in 'Box's will still
--- point to the correct value.
+--- From compiler/ghci/RtClosureInspect.hs
+amap' :: (t -> b) -> Array Int t -> [b]
+amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
+    where g (I# i#) = case indexArray# arr# i# of
+                          (# e #) -> f e
+
+
 getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
 getClosureRaw x = do
     case unpackClosure# x of
 -- This is a hack to cover the bootstrap compiler using the old version of
 -- 'unpackClosure'. The new 'unpackClosure' return values are not merely
 -- a reordering, so using the old version would not work.
+#if MIN_VERSION_ghc_prim(0,5,3)
         (# iptr, dat, pointers #) -> do
-            let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
-                end = fromIntegral nelems - 1
-                rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ]
-                pelems = I# (sizeofArray# pointers)
-                ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers
-            pure (Ptr iptr, rawWds, ptrList)
-
--- From compiler/ghci/RtClosureInspect.hs
-amap' :: (t -> b) -> Array Int t -> [b]
-amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
-    where g (I# i#) = case indexArray# arr# i# of
-                          (# e #) -> f e
+#else
+        (# iptr, pointers, dat #) -> do
+#endif
+             let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
+                 end = fromIntegral nelems - 1
+                 rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ]
+                 pelems = I# (sizeofArray# pointers)
+                 ptrList = amap' Box $ Array 0 (pelems - 1) pelems pointers
+             pure (Ptr iptr, rawWds, ptrList)
+
+getClosureData :: forall rep (a :: TYPE rep) . HasHeapRep a => a -> IO Closure
+getClosureData = getClosureDataX getClosureRaw
+
 
 -- | This function returns a parsed heap representation of the argument _at
 -- this moment_, even if it is unevaluated or an indirection or other exotic
 -- stuff.  Beware when passing something to this function, the same caveats as
 -- for 'asBox' apply.
-getClosure :: a -> IO Closure
-getClosure x = do
-    (iptr, wds, pts) <- getClosureRaw x
+getClosureX :: forall a b . (a -> IO (Ptr StgInfoTable, [Word], [b]))
+            -> a -> IO (GenClosure b)
+getClosureX get_closure_raw x = do
+    (iptr, wds, pts) <- get_closure_raw x
     itbl <- peekItbl iptr
     -- The remaining words after the header
     let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds
@@ -250,7 +258,10 @@ getClosure x = do
                         ++ "found " ++ show (length rawWds)
             pure $ SmallMutArrClosure itbl (rawWds !! 0) pts
 
-        t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
+        t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> do
+            unless (length pts >= 1) $
+                fail $ "Expected at least 1 words to MUT_VAR, found "
+                        ++ show (length pts)
             pure $ MutVarClosure itbl (head pts)
 
         t | t == MVAR_CLEAN || t == MVAR_DIRTY -> do
@@ -266,7 +277,6 @@ getClosure x = do
 
         --  pure $ OtherClosure itbl pts wds
         --
-
         WEAK ->
             pure $ WeakClosure
                 { info = itbl
@@ -276,10 +286,31 @@ getClosure x = do
                 , finalizer = pts !! 3
                 , link = pts !! 4
                 }
+        TSO -> do
+            unless (length pts >= 1) $
+                fail $ "Expected at least 1 ptr argument to TSO, found "
+                        ++ show (length pts)
+            pure $ TSOClosure itbl (pts !! 0)
+        STACK -> do
+            unless (length pts >= 1) $
+                fail $ "Expected at least 1 ptr argument to STACK, found "
+                        ++ show (length pts)
+            let splitWord = rawWds !! 0
+            pure $ StackClosure itbl
+#if defined(WORDS_BIGENDIAN)
+                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+                (fromIntegral splitWord)
+#else
+                (fromIntegral splitWord)
+                (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+#endif
+                (pts !! 0)
+                []
 
         _ ->
             pure $ UnsupportedClosure itbl
 
--- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
+-- | Like 'getClosureDataX', but taking a 'Box', so it is easier to work with.
 getBoxedClosureData :: Box -> IO Closure
 getBoxedClosureData (Box a) = getClosureData a
+
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
index b247266a10..83c593b568 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
@@ -260,6 +260,21 @@ data GenClosure b
         , link        :: !b -- ^ next weak pointer for the capability, can be NULL.
         }
 
+  -- TODO: There are many more fields in a TSO closure which
+  -- are not yet implemented
+  | TSOClosure
+      { info :: !StgInfoTable
+      , tsoStack :: !b
+      }
+
+  | StackClosure
+     { info :: !StgInfoTable
+     , size :: !HalfWord
+     , dirty :: !HalfWord
+     , stackPointer :: !b
+     , stack :: [Word]
+     }
+
     ------------------------------------------------------------
     -- Unboxed unlifted closures
 
diff --git a/rts/Heap.c b/rts/Heap.c
index 0e31a779b4..f840b92ad2 100644
--- a/rts/Heap.c
+++ b/rts/Heap.c
@@ -76,23 +76,15 @@ void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs
     }
 }
 
-StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
-    ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
-
-    StgWord size = heap_view_closureSize(closure);
-    StgWord nptrs = 0;
-    StgWord i;
-
-    // First collect all pointers here, with the comfortable memory bound
-    // of the whole closure. Afterwards we know how many pointers are in
-    // the closure and then we can allocate space on the heap and copy them
-    // there
-    StgClosure *ptrs[size];
-
+/*
+ * Collect the pointers of a closure into the given array. size should be
+ * heap_view_closureSize(closure). Returns the number of pointers collected.
+ */
+static StgWord collect_pointers(StgClosure *closure, StgWord size, StgClosure *ptrs[size]) {
     StgClosure **end;
-    StgClosure **ptr;
-
     const StgInfoTable *info = get_itbl(closure);
+    StgWord nptrs = 0;
+    StgWord i;
 
     switch (info->type) {
         case INVALID_OBJECT:
@@ -123,7 +115,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
         case FUN_0_2:
         case FUN_STATIC:
             end = closure->payload + info->layout.payload.ptrs;
-            for (ptr = closure->payload; ptr < end; ptr++) {
+            for (StgClosure **ptr = closure->payload; ptr < end; ptr++) {
                 ptrs[nptrs++] = *ptr;
             }
             break;
@@ -136,7 +128,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
         case THUNK_0_2:
         case THUNK_STATIC:
             end = ((StgThunk *)closure)->payload + info->layout.payload.ptrs;
-            for (ptr = ((StgThunk *)closure)->payload; ptr < end; ptr++) {
+            for (StgClosure **ptr = ((StgThunk *)closure)->payload; ptr < end; ptr++) {
                 ptrs[nptrs++] = *ptr;
             }
             break;
@@ -213,6 +205,14 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
             ptrs[nptrs++] = (StgClosure *)((StgMVar *)closure)->tail;
             ptrs[nptrs++] = ((StgMVar *)closure)->value;
             break;
+        case TSO:
+            // TODO: Not complete
+            ptrs[nptrs++] = (StgClosure *)((StgTSO *)closure)->stackobj;
+            break;
+        case STACK:
+            ptrs[nptrs++] = (StgClosure *)((StgStack *)closure)->sp;
+            break;
+
 
         case WEAK:
             ptrs[nptrs++] = (StgClosure *)((StgWeak *)closure)->cfinalizers;
@@ -228,6 +228,45 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
             break;
     }
 
+    return nptrs;
+}
+
+StgArrBytes *heap_view_closurePtrsAsWords(Capability *cap, StgClosure *closure) {
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+
+    StgWord size = heap_view_closureSize(closure);
+
+    // First collect all pointers here, with the comfortable memory bound
+    // of the whole closure. Afterwards we know how many pointers are in
+    // the closure and then we can allocate space on the heap and copy them
+    // there
+    StgClosure *ptrs[size];
+    StgWord nptrs = collect_pointers(closure, size, ptrs);
+    StgArrBytes *arr =
+        (StgArrBytes *)allocate(cap, sizeofW(StgArrBytes) + nptrs);
+    TICK_ALLOC_PRIM(sizeofW(StgArrBytes), nptrs, 0);
+    SET_HDR(arr, &stg_ARR_WORDS_info, cap->r.rCCCS);
+    arr->bytes = sizeof(StgWord) * nptrs;
+
+    for (StgWord i = 0; i<nptrs; i++) {
+        arr->payload[i] = (StgWord)ptrs[i];
+    }
+
+    return arr;
+}
+
+StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
+    ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+
+    StgWord size = heap_view_closureSize(closure);
+
+    // First collect all pointers here, with the comfortable memory bound
+    // of the whole closure. Afterwards we know how many pointers are in
+    // the closure and then we can allocate space on the heap and copy them
+    // there
+    StgClosure *ptrs[size];
+    StgWord nptrs = collect_pointers(closure, size, ptrs);
+
     size = nptrs + mutArrPtrsCardTableSize(nptrs);
     StgMutArrPtrs *arr =
         (StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size);
@@ -236,7 +275,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
     arr->ptrs = nptrs;
     arr->size = size;
 
-    for (i = 0; i<nptrs; i++) {
+    for (StgWord i = 0; i<nptrs; i++) {
         arr->payload[i] = ptrs[i];
     }
 
diff --git a/rts/Printer.c b/rts/Printer.c
index 15404e1205..e65f6a23f7 100644
--- a/rts/Printer.c
+++ b/rts/Printer.c
@@ -697,7 +697,7 @@ void printLargeAndPinnedObjects()
     for (uint32_t cap_idx = 0; cap_idx < n_capabilities; ++cap_idx) {
         Capability *cap = capabilities[cap_idx];
 
-        debugBelch("Capability %d: Current pinned object block: %p\n", 
+        debugBelch("Capability %d: Current pinned object block: %p\n",
                    cap_idx, (void*)cap->pinned_object_block);
         for (bdescr *bd = cap->pinned_object_blocks; bd; bd = bd->link) {
             debugBelch("%p\n", (void*)bd);
@@ -852,12 +852,26 @@ extern void DEBUG_LoadSymbols( const char *name STG_UNUSED )
 
 #endif /* USING_LIBBFD */
 
+// findPtr takes a callback so external tools such as ghc-debug can invoke it
+// and intercept the intermediate results. When findPtr successfully finds
+// a closure containing an address then the callback is called on the address
+// of that closure. The `StgClosure` argument is an untagged closure pointer.
+typedef void (*FindPtrCb)(void *user, StgClosure *);
+
 void findPtr(P_ p, int);                /* keep gcc -Wall happy */
+void findPtrCb(FindPtrCb cb, void *, P_ p);  /* keep gcc -Wall happy */
+
+static void
+findPtr_default_callback(void *user STG_UNUSED, StgClosure * closure){
+  debugBelch("%p = ", closure);
+  printClosure((StgClosure *)closure);
+}
+
 
 int searched = 0;
 
 static int
-findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
+findPtrBlocks (FindPtrCb cb, void* user, StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
 {
     StgPtr q, r, end;
     for (; bd; bd = bd->link) {
@@ -875,8 +889,7 @@ findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
                         }
                         end = r + closure_sizeW((StgClosure*)r);
                         if (q < end) {
-                            debugBelch("%p = ", r);
-                            printClosure((StgClosure *)r);
+                            cb(user, (StgClosure *) r);
                             arr[i++] = r;
                             break;
                         }
@@ -893,8 +906,8 @@ findPtrBlocks (StgPtr p, bdescr *bd, StgPtr arr[], int arr_size, int i)
     return i;
 }
 
-void
-findPtr(P_ p, int follow)
+static void
+findPtr_gen(FindPtrCb cb, void *user, P_ p, int follow)
 {
   uint32_t g, n;
   bdescr *bd;
@@ -916,24 +929,35 @@ findPtr(P_ p, int follow)
 
   for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
       bd = generations[g].blocks;
-      i = findPtrBlocks(p,bd,arr,arr_size,i);
+      i = findPtrBlocks(cb, user,p,bd,arr,arr_size,i);
       bd = generations[g].large_objects;
-      i = findPtrBlocks(p,bd,arr,arr_size,i);
+      i = findPtrBlocks(cb, user, p,bd,arr,arr_size,i);
       if (i >= arr_size) return;
       for (n = 0; n < n_capabilities; n++) {
-          i = findPtrBlocks(p, gc_threads[n]->gens[g].part_list,
+          i = findPtrBlocks(cb, user, p, gc_threads[n]->gens[g].part_list,
                             arr, arr_size, i);
-          i = findPtrBlocks(p, gc_threads[n]->gens[g].todo_bd,
+          i = findPtrBlocks(cb, user, p, gc_threads[n]->gens[g].todo_bd,
                             arr, arr_size, i);
       }
       if (i >= arr_size) return;
   }
   if (follow && i == 1) {
+      ASSERT(cb == &findPtr_default_callback);
       debugBelch("-->\n");
+      // Non-standard callback expects follow=0
       findPtr(arr[0], 1);
   }
 }
 
+void
+findPtr(P_ p, int follow){
+  findPtr_gen(&findPtr_default_callback, NULL, p, follow);
+}
+
+void findPtrCb(FindPtrCb cb, void* user, P_ p){
+  findPtr_gen(cb, user, p, 0);
+}
+
 const char *what_next_strs[] = {
   [0]               = "(unknown)",
   [ThreadRunGHC]    = "ThreadRunGHC",
diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c
index 26433ac209..209f608f6e 100644
--- a/rts/RtsAPI.c
+++ b/rts/RtsAPI.c
@@ -18,6 +18,7 @@
 #include "StablePtr.h"
 #include "Threads.h"
 #include "Weak.h"
+#include "StableName.h"
 
 /* ----------------------------------------------------------------------------
    Building Haskell objects from C datatypes.
@@ -645,6 +646,93 @@ rts_unlock (Capability *cap)
     }
 }
 
+#if defined(THREADED_RTS)
+static bool rts_paused = false;
+// Halt execution of all Haskell threads.
+// It is different to rts_lock because it pauses all capabilities. rts_lock
+// only pauses a single capability.
+RtsPaused rts_pause (void)
+{
+    struct RtsPaused_ paused;
+    paused.pausing_task = newBoundTask();
+    stopAllCapabilities(&paused.capabilities, paused.pausing_task);
+    rts_paused = true;
+    return paused;
+}
+
+void rts_unpause (RtsPaused  paused)
+{
+    rts_paused = false;
+    releaseAllCapabilities(n_capabilities, paused.capabilities, paused.pausing_task);
+    freeTask(paused.pausing_task);
+}
+
+
+void rts_listThreads(ListThreadsCb cb, void *user)
+{
+    ASSERT(rts_paused);
+    for (uint32_t g=0; g < RtsFlags.GcFlags.generations; g++) {
+        StgTSO *tso = generations[g].threads;
+        while (tso != END_TSO_QUEUE) {
+            cb(user, tso);
+            tso = tso->global_link;
+        }
+    }
+}
+
+struct list_roots_ctx {
+    ListRootsCb cb;
+    void *user;
+};
+
+// This is an evac_fn.
+static void list_roots_helper(void *user, StgClosure **p) {
+    struct list_roots_ctx *ctx = (struct list_roots_ctx *) user;
+    ctx->cb(ctx->user, *p);
+}
+
+void rts_listMiscRoots (ListRootsCb cb, void *user)
+{
+    struct list_roots_ctx ctx;
+    ctx.cb = cb;
+    ctx.user = user;
+
+    ASSERT(rts_paused);
+    threadStableNameTable(&list_roots_helper, (void *)&ctx);
+    threadStablePtrTable(&list_roots_helper, (void *)&ctx);
+}
+
+#else
+RtsPaused rts_pause (void)
+{
+    errorBelch("Warning: Pausing the RTS is only possible for "
+               "multithreaded RTS.");
+    struct RtsPaused_ paused;
+    paused.pausing_task = NULL;
+    paused.capabilities = NULL;
+    return paused;
+}
+
+void rts_unpause (RtsPaused  paused STG_UNUSED)
+{
+    errorBelch("Warning: Unpausing the RTS is only possible for "
+               "multithreaded RTS.");
+}
+
+
+void rts_listThreads(ListThreadsCb cb STG_UNUSED, void *user STG_UNUSED)
+{
+    errorBelch("Warning: Listing RTS-threads is only possible for "
+               "multithreaded RTS.");
+}
+
+void rts_listMiscRoots (ListRootsCb cb STG_UNUSED, void *user STG_UNUSED)
+{
+    errorBelch("Warning: Listing MiscRoots is only possible for "
+               "multithreaded RTS.");
+}
+#endif
+
 void rts_done (void)
 {
     freeMyTask();
diff --git a/rts/Schedule.c b/rts/Schedule.c
index ce1a1fc060..3d8ee25511 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -1537,7 +1537,7 @@ static void acquireAllCapabilities(Capability *cap, Task *task)
 void releaseAllCapabilities(uint32_t n, Capability *keep_cap, Task *task)
 {
     uint32_t i;
-
+    ASSERT( task != NULL);
     for (i = 0; i < n; i++) {
         Capability *tmpcap = capabilities[i];
         if (keep_cap != tmpcap) {
diff --git a/rts/Task.c b/rts/Task.c
index 11ba5f1581..4a2d339c41 100644
--- a/rts/Task.c
+++ b/rts/Task.c
@@ -36,8 +36,6 @@ uint32_t currentWorkerCount;
 uint32_t peakWorkerCount;
 
 static int tasksInitialized = 0;
-
-static void   freeTask  (Task *task);
 static Task * newTask   (bool);
 
 #if defined(THREADED_RTS)
@@ -173,7 +171,7 @@ void freeMyTask (void)
     setMyTask(NULL);
 }
 
-static void
+void
 freeTask (Task *task)
 {
     InCall *incall, *next;
diff --git a/rts/Task.h b/rts/Task.h
index 17bcbe2da4..1f30f95b8f 100644
--- a/rts/Task.h
+++ b/rts/Task.h
@@ -188,6 +188,7 @@ isWorker (Task *task)
 // Linked list of all tasks.
 //
 extern Task *all_tasks;
+void   freeTask  (Task *task);
 
 // The all_tasks list is protected by the all_tasks_mutex
 #if defined(THREADED_RTS)
@@ -200,29 +201,6 @@ extern Mutex all_tasks_mutex;
 void initTaskManager (void);
 uint32_t  freeTaskManager (void);
 
-// Create a new Task for a bound thread.  This Task must be released
-// by calling boundTaskExiting.  The Task is cached in
-// thread-local storage and will remain even after boundTaskExiting()
-// has been called; to free the memory, see freeMyTask().
-//
-Task* newBoundTask (void);
-
-// Return the current OS thread's Task, which is created if it doesn't already
-// exist.  After you have finished using RTS APIs, you should call freeMyTask()
-// to release this thread's Task.
-Task* getTask (void);
-
-// The current task is a bound task that is exiting.
-//
-void boundTaskExiting (Task *task);
-
-// Free a Task if one was previously allocated by newBoundTask().
-// This is not necessary unless the thread that called newBoundTask()
-// will be exiting, or if this thread has finished calling Haskell
-// functions.
-//
-void freeMyTask(void);
-
 // Notify the task manager that a task has stopped.  This is used
 // mainly for stats-gathering purposes.
 // Requires: sched_mutex.
diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in
index b9a67c7ca1..e1e514c806 100644
--- a/rts/rts.cabal.in
+++ b/rts/rts.cabal.in
@@ -150,6 +150,7 @@ library
                       rts/StableName.h
                       rts/StablePtr.h
                       rts/StaticPtrTable.h
+                      rts/Task.h
                       rts/TTY.h
                       rts/Threads.h
                       rts/Ticky.h