From fe1c2284d64ef3d12367572c760accda72d8cd44 Mon Sep 17 00:00:00 2001
From: Zubin Duggal <zubin.duggal@gmail.com>
Date: Fri, 22 Nov 2024 19:16:17 +0530
Subject: [PATCH] Add streaming support to GHC debug brick

This is accomplished by a new tracing module GHC.Debug.StreamedTrace that is
able to produce results incrementally.
---
 client/ghc-debug-client.cabal         |   4 +-
 client/src/GHC/Debug/Retainers.hs     |  52 +++----
 client/src/GHC/Debug/StreamedTrace.hs | 211 ++++++++++++++++++++++++++
 ghc-debug-brick/ghc-debug-brick.cabal |   2 +
 ghc-debug-brick/src/AsyncBuffer.hs    |  44 ++++++
 ghc-debug-brick/src/IOTree.hs         |  31 ++--
 ghc-debug-brick/src/Lib.hs            |  72 +++------
 ghc-debug-brick/src/Main.hs           | 107 +++++++------
 ghc-debug-brick/src/Model.hs          |  10 +-
 9 files changed, 385 insertions(+), 148 deletions(-)
 create mode 100644 client/src/GHC/Debug/StreamedTrace.hs
 create mode 100644 ghc-debug-brick/src/AsyncBuffer.hs

diff --git a/client/ghc-debug-client.cabal b/client/ghc-debug-client.cabal
index 16eaa1d3..8f6b0340 100644
--- a/client/ghc-debug-client.cabal
+++ b/client/ghc-debug-client.cabal
@@ -26,6 +26,7 @@ library
                        GHC.Debug.Profile,
                        GHC.Debug.Profile.Types,
                        GHC.Debug.Trace,
+                       GHC.Debug.StreamedTrace,
                        GHC.Debug.ParTrace,
                        GHC.Debug.Count,
                        GHC.Debug.Strings,
@@ -63,7 +64,8 @@ library
                        stm ^>= 2.5,
                        vector ^>= 0.13.1 ,
                        bytestring >= 0.11,
-                       contra-tracer ^>= 0.2.0
+                       contra-tracer ^>= 0.2.0,
+                       extra
 
   hs-source-dirs:      src
   default-language:    Haskell2010
diff --git a/client/src/GHC/Debug/Retainers.hs b/client/src/GHC/Debug/Retainers.hs
index a5df6545..0cdf6f08 100644
--- a/client/src/GHC/Debug/Retainers.hs
+++ b/client/src/GHC/Debug/Retainers.hs
@@ -24,14 +24,12 @@ import Control.Monad.State
 import GHC.Debug.Trace
 import GHC.Debug.Types.Graph
 import Control.Monad
+import GHC.Debug.StreamedTrace
 
 import qualified Data.Set as Set
 import Control.Monad.RWS
 import Data.Word
-
-addOne :: a -> (Maybe Int, [a]) -> (Maybe Int, [a])
-addOne _ (Just 0, cp) = (Just 0, cp)
-addOne cp (n, cps)    = (subtract 1 <$> n, cp : cps)
+import Data.List.NonEmpty ( NonEmpty(..) )
 
 data EraRange
   = EraRange { startEra :: Word64, endEra :: Word64} -- inclusive
@@ -100,27 +98,27 @@ matchesFilter filter ptr sc parents = case filter of
 findRetainersOf :: Maybe Int
                 -> [ClosurePtr]
                 -> [ClosurePtr]
-                -> DebugM [[ClosurePtr]]
+                -> DebugM (ResultStream (NonEmpty ClosurePtr) () (Maybe ()))
 findRetainersOf limit cps bads =
   findRetainers limit (AddressFilter (`Set.member` bad_set)) cps
   where
     bad_set = Set.fromList bads
 
 findRetainersOfConstructor :: Maybe Int
-                           -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
+                           -> [ClosurePtr] -> String -> DebugM (ResultStream (NonEmpty ClosurePtr) () (Maybe ()))
 findRetainersOfConstructor limit rroots con_name =
   findRetainers limit (ConstructorDescFilter ((== con_name) . name)) rroots
 
 findRetainersOfConstructorExact
   :: Maybe Int
-  -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
+  -> [ClosurePtr] -> String -> DebugM (ResultStream (NonEmpty ClosurePtr) () (Maybe ()))
 findRetainersOfConstructorExact limit rroots clos_name =
   findRetainers limit (InfoSourceFilter ((== clos_name) . infoName)) rroots
 
 findRetainersOfEra
   :: Maybe Int
   -> EraRange
-  -> [ClosurePtr] -> DebugM [[ClosurePtr]]
+  -> [ClosurePtr] -> DebugM (ResultStream (NonEmpty ClosurePtr) () (Maybe ()))
 findRetainersOfEra limit eras rroots =
   findRetainers limit filter rroots
   where
@@ -128,7 +126,7 @@ findRetainersOfEra limit eras rroots =
 
 findRetainersOfArrWords
   :: Maybe Int
-  -> [ClosurePtr] -> Size -> DebugM [[ClosurePtr]]
+  -> [ClosurePtr] -> Size -> DebugM (ResultStream (NonEmpty ClosurePtr) () (Maybe ()))
 findRetainersOfArrWords limit rroots lim =
   findRetainers limit filter rroots
   where
@@ -138,7 +136,7 @@ findRetainersOfArrWords limit rroots lim =
 
 findRetainersOfInfoTable
   :: Maybe Int
-  -> [ClosurePtr] -> InfoTablePtr -> DebugM [[ClosurePtr]]
+  -> [ClosurePtr] -> InfoTablePtr -> DebugM (ResultStream (NonEmpty ClosurePtr) () (Maybe ()))
 findRetainersOfInfoTable limit rroots info_ptr =
   findRetainers limit (InfoPtrFilter (== info_ptr)) rroots
 
@@ -148,28 +146,26 @@ findRetainersOfInfoTable limit rroots info_ptr =
 -- such as 10.
 findRetainers :: Maybe Int
   -> ClosureFilter
-  -> [ClosurePtr] -> DebugM [[ClosurePtr]]
-findRetainers limit filter rroots = (\(_, r, _) -> snd r) <$> runRWST (traceFromM funcs rroots) [] (limit, [])
+  -> [ClosurePtr] -> DebugM (ResultStream (NonEmpty ClosurePtr) () (Maybe ()))
+findRetainers limit filter rroots = traceStreamResults rroots limit [] funcs
   where
-    funcs = justClosures closAccum
+    funcs = justStreamClosures closAccum
     -- Add clos
     closAccum  :: ClosurePtr
                -> SizedClosure
-               -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-               -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-    closAccum _ (noSize -> WeakClosure {}) _ = return ()
-    closAccum cp sc k = do
-      ctx <- ask
-      b <- lift $ matchesFilter filter cp sc ctx
-      if b
-      then do
-        modify' (addOne (cp: ctx))
-        local (cp:) k
-      else do
-        (lim, _) <- get
-        case lim of
-          Just 0 -> return ()
-          _ -> local (cp:) k
+               -> Maybe Int
+               -> [ClosurePtr]
+               -> DebugM (Step (Maybe Int) [ClosurePtr] (NonEmpty ClosurePtr) ())
+    closAccum _ (noSize -> WeakClosure {}) l _ = return $ Step Nothing (Prune l)
+    closAccum cp sc remaining ctx
+      | Just r <- remaining
+      , r <= 0 = return $ Step Nothing (End ())
+      | otherwise = do
+        b <- matchesFilter filter cp sc ctx
+        let next = Continue (if b then (subtract 1 <$> remaining) else remaining) (cp:ctx)
+        if b
+        then return $ Step (Just (cp:|ctx))  next
+        else return $ Step Nothing next
 
 addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureP, Maybe SourceInformation)]
 addLocationToStack r = do
diff --git a/client/src/GHC/Debug/StreamedTrace.hs b/client/src/GHC/Debug/StreamedTrace.hs
new file mode 100644
index 00000000..01fa242a
--- /dev/null
+++ b/client/src/GHC/Debug/StreamedTrace.hs
@@ -0,0 +1,211 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveFunctor #-}
+-- | Functions to support the constant space traversal of a heap.
+module GHC.Debug.StreamedTrace ( justStreamClosures, traceStreamResults , StreamedTraceFunctions(..), ResultStream(..), Step (..), Update(..), mapStream, mapMStream) where
+
+import           GHC.Debug.Types
+import GHC.Debug.Client.Monad
+import           GHC.Debug.Client.Query
+
+import qualified Data.IntMap as IM
+import Data.Array.BitArray.IO
+import Control.Monad.Reader
+import Control.Monad
+import Data.IORef
+import Data.Word
+import Data.Bitraversable
+import Data.Coerce
+import Control.Monad.RWS
+import Control.Monad.Extra
+import Data.Monoid
+
+newtype VisitedSet = VisitedSet (IM.IntMap (IOBitArray Word16))
+
+data TraceState = TraceState { visited :: !VisitedSet, n :: !Int }
+
+
+getKeyPair :: ClosurePtr -> (Int, Word16)
+getKeyPair cp =
+  let BlockPtr raw_bk = applyBlockMask cp
+      bk = fromIntegral raw_bk `div` 8
+      offset = getBlockOffset cp `div` 8
+  in (bk, fromIntegral offset)
+
+checkVisit :: ClosurePtr -> IORef TraceState -> IO (Maybe Int, Bool)
+checkVisit cp mref = do
+  st <- readIORef mref
+  let VisitedSet v = visited st
+      num_visited = n st
+      (bk, offset) = getKeyPair cp
+  case IM.lookup bk v of
+    Nothing -> do
+      na <- newArray (0, fromIntegral (blockMask `div` 8)) False
+      writeArray na offset True
+      writeIORef mref (TraceState (VisitedSet (IM.insert bk na v)) (num_visited + 1))
+      return (Just num_visited, False)
+    Just bm -> do
+      res <- readArray bm offset
+      unless res (writeArray bm offset True)
+      return (Nothing, res)
+
+data Update s c r
+  = Continue s c -- Continue updating local context
+  | Prune s      -- Prune current branch
+  | End r        -- End search (global)
+
+data Step s c a r = Step (Maybe a) (Update s c r)
+
+data StreamedTraceFunctions s c a r =
+      StreamedTraceFunctions
+      { papTrace     :: !(GenPapPayload ClosurePtr -> s -> c -> DebugM (Step s c a r))
+      , srtTrace     :: !(GenSrtPayload ClosurePtr -> s -> c -> DebugM (Step s c a r))
+      , stackTrace   :: !(GenStackFrames SrtCont ClosurePtr -> s -> c -> DebugM (Step s c a r))
+      , closTrace    :: !(ClosurePtr -> SizedClosure -> s -> c -> DebugM (Step s c a r))
+      , visitedVal   :: !(ClosurePtr -> s -> c -> DebugM (Step s c a r))
+      , conDescTrace :: !(ConstrDesc -> s -> c -> DebugM (Step s c a r))
+      , ccsTrace     :: !(CCSPtr -> CCSPayload -> s -> c -> DebugM (Step s c a r))
+      }
+
+justStreamClosures :: (ClosurePtr -> SizedClosure -> s -> c -> DebugM (Step s c a r)) -> StreamedTraceFunctions s c a r
+justStreamClosures f = StreamedTraceFunctions nop nop nop f nop nop (const nop)
+  where
+    nop _ s c = pure $ Step Nothing (Continue s c)
+
+data ResultStream a b r
+  = Yield a (ResultStream a b r)
+  | Wait (DebugM (ResultStream a b r))
+  | Terminated b
+  | Done r
+  deriving (Functor)
+
+mapStream :: (a -> a') -> ResultStream a b r -> ResultStream a' b r
+mapStream f (Yield x xs) = Yield (f x) (mapStream f xs)
+mapStream f (Wait xs) = Wait (fmap (mapStream f) xs)
+mapStream _ (Terminated x) = Terminated x
+mapStream _ (Done x) = Done x
+
+mapMStream :: (a -> DebugM a') -> ResultStream a b r -> ResultStream a' b r
+mapMStream f (Yield x xs) = Wait $ do
+  x' <- f x
+  pure $ Yield x' (mapMStream f xs)
+mapMStream f (Wait xs) = Wait $ do
+  x <- xs
+  pure $ mapMStream f x
+mapMStream _ (Terminated x) = Terminated x
+mapMStream _ (Done x) = Done x
+
+
+instance Applicative (ResultStream a b) where
+  pure = Done
+  (<*>) = ap
+
+instance Monad (ResultStream a b) where
+  xs >>= f = go xs
+    where
+      go (Yield a as) = Yield a (go as)
+      go (Wait m) = Wait (fmap go m)
+      go (Done r) = f r
+      go (Terminated b) = Terminated b
+
+runTraceFunc :: (Monad m, Monoid w) => (s -> c -> m a) -> RWST c w s m a
+runTraceFunc f = do
+  (s, c) <- liftA2 (,) get ask
+  lift $ f s c
+
+yield :: a -> ResultStream a b ()
+yield x = Yield x (Done ())
+
+wait :: M s c r DebugM x -> StreamM s c r a x
+wait k = do
+  (s, c) <- liftA2 (,) get ask
+  (r, s') <- lift $ Wait $ do
+    (res, state, _)  <- runRWST k c s
+    return $ Done (res, state)
+  put s'
+  return r
+
+type M s c r m a = RWST c (Last r) s m a
+
+type StreamM s c r a x = M s c r (ResultStream a r) x
+
+-- Given gc roots, initial global state and path state, return a streamed traversal
+-- with state 's', context 'c', values 'a' and result 'r' or 'Maybe r' depending on if
+-- the stream was terminated early or not
+traceStreamResults :: forall s c a r. [ClosurePtr] -> s -> c -> StreamedTraceFunctions s c a r -> DebugM (ResultStream a r (Maybe r))
+traceStreamResults cps s c k = do
+  st <- unsafeLiftIO (newIORef (TraceState (VisitedSet IM.empty) 1))
+  let go :: [ClosurePtr] -> M s c r (ResultStream a r) ()
+      go [] = pure ()
+      go (cp:cps) =  do
+        b <- wait $ lift $ do
+          (mnum_visited, b) <- unsafeLiftIO (checkVisit cp st)
+          forM_ mnum_visited $ \num_visited ->
+            when (num_visited `mod` 10_000 == 0) $ traceMsg ("Traced: " ++ show num_visited)
+          return b
+        if b
+        then do
+          step <- wait (runTraceFunc (visitedVal k cp))
+          goStep step $ pure ()
+        else do
+          (step, sc) <- wait $ do
+            sc <- lift $ dereferenceClosure cp
+            step <- runTraceFunc (closTrace k cp sc)
+            return (step, sc)
+          goStep step $ do
+            () <$ hextraverse goccs gosrt gop gocd gos go1 sc
+          go cps
+
+      go1 cp = go [cp]
+
+      simpleTrace deref trace x = do
+        (step, x') <- wait $ do
+          x' <- lift $ deref x
+          step <- runTraceFunc (trace k x')
+          return (step, x')
+        goStep step $
+          () <$ (traverse go1 x')
+
+      gos = simpleTrace dereferenceStack stackTrace
+
+      gocd x = do
+        (step, x') <- wait $ do
+          x' <- lift $ dereferenceConDesc x
+          step <- runTraceFunc (conDescTrace k x')
+          return (step, x')
+        goStep step $ pure ()
+
+      gop = simpleTrace dereferencePapPayload papTrace
+
+      gosrt = simpleTrace dereferenceSRT srtTrace
+
+      goccs p = do
+        b <- wait $ do
+          (mnum_visited, b) <- lift $ unsafeLiftIO (checkVisit (coerce p) st)
+          return b
+        if b
+        then return ()
+        else do
+          (step, p') <- wait $ do
+            p' <- lift $ dereferenceCCS p
+            step <- runTraceFunc (ccsTrace k p p')
+            return (step, p')
+          goStep step $ () <$ (bitraverse goccs pure p')
+
+      goStep :: Step s c a r -> M s c r (ResultStream a r) () -> M s c r (ResultStream a r) ()
+      goStep (Step v u) k = do
+          lift $ whenJust v $ yield
+          case u of
+            End r -> lift $ Terminated r
+            Prune s -> put s
+            Continue s c -> do
+              put s
+              local (const c) k
+
+  pure $ fmap (getLast . snd) (execRWST (go cps) c s)
diff --git a/ghc-debug-brick/ghc-debug-brick.cabal b/ghc-debug-brick/ghc-debug-brick.cabal
index 874b604c..59583d7c 100644
--- a/ghc-debug-brick/ghc-debug-brick.cabal
+++ b/ghc-debug-brick/ghc-debug-brick.cabal
@@ -16,6 +16,7 @@ executable ghc-debug-brick
   other-modules:       Model
                      , Namespace
                      , IOTree
+                     , AsyncBuffer
                      , Common
                      , Lib
   build-depends:       base >=4.16 && <5
@@ -39,6 +40,7 @@ executable ghc-debug-brick
                      , contra-tracer
                      , bytestring
                      , byteunits
+                     , stm
   hs-source-dirs:    src
   default-language:    Haskell2010
   ghc-options: -threaded -Wall "-with-rtsopts=-N -qn1"
diff --git a/ghc-debug-brick/src/AsyncBuffer.hs b/ghc-debug-brick/src/AsyncBuffer.hs
new file mode 100644
index 00000000..c23c5098
--- /dev/null
+++ b/ghc-debug-brick/src/AsyncBuffer.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module AsyncBuffer where
+
+
+import Control.Concurrent
+import Control.Monad.IO.Class
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TVar
+import Control.Concurrent.STM.TQueue
+import GHC.Debug.Client
+import GHC.Debug.Client.Monad
+import GHC.Debug.StreamedTrace
+
+type DList a = [a] -> [a]
+
+data AsyncBuffer a b r
+  = AsyncBuffer
+  { current :: TQueue a
+  , currentSize :: TVar Int
+  , bufferThread :: ThreadId
+  , bufferStatus :: MVar (Either b r)
+  }
+
+sampleAsyncBuffer :: AsyncBuffer a b r -> IO [a]
+sampleAsyncBuffer AsyncBuffer{current} = atomically $ flushTQueue current
+
+streamBuffer :: Debuggee -> ResultStream a b r -> IO (AsyncBuffer a b r)
+streamBuffer dbg xs = do
+  cur <- newTQueueIO
+  sz <- newTVarIO 0
+  done <- newEmptyMVar
+  let go (Yield x xs) = do
+        asd <- unsafeLiftIO $ readTVarIO sz
+        unsafeLiftIO $ atomically $ do
+          writeTQueue cur x
+          modifyTVar' sz (+1)
+        go xs
+      go (Wait a) = do
+        x <- a
+        go x
+      go (Terminated b) = unsafeLiftIO $ putMVar done (Left b)
+      go (Done b) = unsafeLiftIO $ putMVar done (Right b)
+  tid <- forkIO $ run dbg $ go xs
+  return $ AsyncBuffer cur sz tid done
diff --git a/ghc-debug-brick/src/IOTree.hs b/ghc-debug-brick/src/IOTree.hs
index 48b683f4..df5f8557 100644
--- a/ghc-debug-brick/src/IOTree.hs
+++ b/ghc-debug-brick/src/IOTree.hs
@@ -11,8 +11,8 @@ module IOTree
   , RowState(..)
   , RowCtx(..)
   , ioTree
-  , setIOTreeRoots
   , getIOTreeRoots
+  , addIOTreeRoots
   , renderIOTree
   , handleIOTreeEvent
   , ioTreeSelection
@@ -42,11 +42,12 @@ import qualified Graphics.Vty.Input.Events as Vty
 import           Graphics.Vty.Input.Events (Key(..))
 import           Lens.Micro ((^.))
 
+import AsyncBuffer
 
 -- A tree style list where items can be expanded and collapsed
 data IOTree node name = IOTree
     { _name :: name
-    , _roots :: [IOTreeNode node name]
+    , _roots :: DList (IOTreeNode node name)
     , _getChildren :: (node -> IO [node])
     , _renderRow :: RowState     -- is row expanded?
                  -> Bool         -- is row selected?
@@ -63,11 +64,11 @@ data IOTree node name = IOTree
 data RowState = Expanded Bool | Collapsed
 data RowCtx = NotLastRow | LastRow
 
-setIOTreeRoots :: [node] -> IOTree node name ->  IOTree node name
-setIOTreeRoots newRoots iot = iot { _roots = (nodeToTreeNode (_getChildren iot) <$> newRoots) }
-
 getIOTreeRoots :: IOTree node name -> [node]
-getIOTreeRoots iot = map _node (_roots iot)
+getIOTreeRoots iot = map _node (_roots iot [])
+
+addIOTreeRoots :: IOTree node name -> [node] -> IOTree node name
+addIOTreeRoots iot xs = iot { _roots = (_roots iot (map (nodeToTreeNode (_getChildren iot)) xs) ++) }
 
 
 
@@ -101,7 +102,7 @@ ioTree
 ioTree name rootNodes getChildrenIO renderRow
   = IOTree
     { _name = name
-    , _roots = nodeToTreeNode getChildrenIO <$> rootNodes
+    , _roots = ((nodeToTreeNode getChildrenIO <$> rootNodes) ++)
     , _getChildren = getChildrenIO
     , _renderRow = renderRow
     , _selection = if null rootNodes then [] else [0]
@@ -140,7 +141,7 @@ drawTreeElements (IOTree widgetName treeNodes _ renderRow pathTop) =
 
     -- Take (numPerHeight * 2) elements, or whatever is left
     let
-      rs = flattenTree 0 [] treeNodes pathTop
+      rs = flattenTree 0 [] (treeNodes []) pathTop
       es = take (numPerHeight * 2) $ drop start rs
 
       idx = fromMaybe 0 (List.findIndex (_nodeSelected) rs)
@@ -290,7 +291,7 @@ viewUnsafeDown :: HasCallStack => IOTreeView node name -> Int -> IOTreeView node
 viewUnsafeDown view i
   | viewIsCollapsed view = error "viewUnsafeDown: view must be expanded"
   | otherwise = case view of
-      Root t -> Node (\c -> Root t{ _roots = listSet i c (_roots t) }) i (t !. i)
+      Root t -> Node (\c -> Root t{ _roots = (listSet i c (_roots t []) ++) }) i (t !. i)
       Node mkParent ixInParent t -> Node
                   (\c -> Node mkParent ixInParent (unsafeSetChild c i t))
                   i
@@ -305,7 +306,7 @@ viewPrevVisible view = case viewPrevSibling view of
     then view'
     else let
       n = case view' of
-            Root t -> length (_roots t) - 1
+            Root t -> length (_roots t []) - 1
             Node _ _ t -> either (error "Impossible! view' is expanded") length (_children t)
       in if n == 0 then view' else viewLastVisibleChild $ viewUnsafeDown view' (n-1)
 
@@ -320,7 +321,7 @@ viewNextVisible view = let
     then Nothing
     else let
       nullChildren = case view' of
-            Root t -> null (_roots t)
+            Root t -> null (_roots t [])
             Node _ _ t -> either (error "Impossible! view' is expanded") null (_children t)
       in if nullChildren then Nothing else Just (viewUnsafeDown view' 0)
 
@@ -339,7 +340,7 @@ viewNextSibling t = case t of
   Node mkParent ixInParent t' -> let
     parent = mkParent t'
     nSiblings = case parent of
-        Root t'' -> length (_roots t'')
+        Root t'' -> length (_roots t'' [])
         Node _ _ t'' -> length (either (error "Impossible! syblings must be expanded") id (_children t''))
     in if ixInParent + 1 == nSiblings
         then Nothing
@@ -357,7 +358,7 @@ viewCollapse t = case t of
 -- the current node.
 viewCollapseAll :: HasCallStack => IOTreeView node name -> IOTreeView node name
 viewCollapseAll tv = case tv of
-    Root t            -> Root (t {_roots = fmap go (_roots t)})
+    Root t            -> Root (t {_roots = (fmap go (_roots t []) ++)})
     Node mkParent i t -> case _children t of
       Left cs  -> Node mkParent i t {_children = Left $ fmap go <$> cs}
       Right cs -> Node mkParent i t {_children = Left . pure $ fmap go cs }
@@ -370,7 +371,7 @@ viewCollapseAll tv = case tv of
 -- | Expand the current node. Returns the children of the current node.
 viewExpand :: HasCallStack => IOTreeView node name -> IO (IOTreeView node name, [IOTreeNode node name])
 viewExpand t = case t of
-  Root t' -> return (t, _roots t')
+  Root t' -> return (t, _roots t' [])
   Node mkParent i t' -> case _children t' of
     Left getChildren -> do
       cs <- getChildren
@@ -386,7 +387,7 @@ viewIsCollapsed t = case t of
     Right{} -> False
 
 (!.) :: IOTree node name -> Int -> IOTreeNode node name
-t !. i = _roots t !! i
+t !. i = _roots t [] !! i
 
 (!) :: IOTreeNode node name -> Int -> IOTreeNode node name
 t ! i = case _children t of
diff --git a/ghc-debug-brick/src/Lib.hs b/ghc-debug-brick/src/Lib.hs
index 07413e8f..3a4f484c 100644
--- a/ghc-debug-brick/src/Lib.hs
+++ b/ghc-debug-brick/src/Lib.hs
@@ -63,10 +63,6 @@ module Lib
     -- * Dominator Tree
   , Size(..)
   , RetainerSize(..)
-    -- * Reverse Edge Map
-  , HG.mkReverseGraph
-  , reverseClosureReferences
-  , lookupHeapGraph
 
     -- * Profiling
   , profile
@@ -90,7 +86,6 @@ module Lib
   , CCPayload
   , GenCCSPayload
   , toPtr
-  , dereferencePtr
   , ConstrDesc(..)
   , ConstrDescCont
   , GenPapPayload(..)
@@ -143,6 +138,7 @@ import qualified Data.Set as Set
 import Data.Int
 import GHC.Debug.Client.Monad (DebugM)
 import Common
+import GHC.Debug.StreamedTrace
 
 initialTraversal :: Debuggee -> IO (HG.HeapGraph Size)
 initialTraversal e = run e $ do
@@ -228,7 +224,7 @@ rootClosures :: Debuggee -> IO [Closure]
 rootClosures e = run e $ do
   closurePtrs <- request RequestRoots
   closures <- GD.dereferenceClosures closurePtrs
-  return [ Closure closurePtr' closure
+  return [ Closure closurePtr' closure []
             | closurePtr' <- closurePtrs
             | closure <- closures
             ]
@@ -245,7 +241,7 @@ savedClosures :: Debuggee -> IO [Closure]
 savedClosures e = run e $ do
   closurePtrs <- request RequestSavedObjects
   closures <- GD.dereferenceClosures closurePtrs
-  return $ zipWith Closure
+  return $ zipWith (\cp dcp -> Closure cp dcp [])
             closurePtrs
             closures
 
@@ -274,13 +270,15 @@ snapshot dbg fp = do
   createDirectoryIfMissing True dir
   GD.run dbg $ GD.snapshot (dir </> fp)
 
-retainersOf :: Maybe Int -> DebugM ClosureFilter -> Maybe [ClosurePtr] -> Debuggee -> IO [[Closure]]
+retainersOf :: Maybe Int -> DebugM ClosureFilter -> Maybe [ClosurePtr] -> Debuggee -> IO (ResultStream Closure () (Maybe ()))
 retainersOf n retainer_filter mroots dbg = do
   run dbg $ do
     roots <- maybe GD.gcRoots return mroots
     closfilter <- retainer_filter
-    stack <- GD.findRetainers n closfilter roots
-    traverse (\cs -> zipWith Closure cs <$> (GD.dereferenceClosures cs)) stack
+    cpss <- GD.findRetainers n closfilter roots
+    pure $ flip mapMStream cpss $ \(cp:|parents) -> do
+      x <- GD.dereferenceClosure cp
+      return $ Closure cp x parents
 
 findAllChildrenOfCCs :: Int64 -> Debuggee -> IO (Set.Set CCSPtr)
 findAllChildrenOfCCs ccId dbg = do
@@ -327,6 +325,7 @@ data DebugClosure ccs srt p cd s c
   = Closure
     { _closurePtr :: ClosurePtr
     , _closureSized :: DebugClosureWithSize ccs srt p cd s c
+    , _closurePath :: [ClosurePtr]
     }
   | Stack
     { _stackPtr :: StackCont
@@ -335,37 +334,33 @@ data DebugClosure ccs srt p cd s c
   deriving Show
 
 toPtr :: DebugClosure ccs srt p cd s c -> Ptr
-toPtr (Closure cp _) = CP cp
+toPtr (Closure cp _ _) = CP cp
 toPtr (Stack sc _)   = SP sc
 
 data Ptr = CP ClosurePtr | SP StackCont deriving (Eq, Ord)
 
 
-dereferencePtr :: Debuggee -> Ptr -> IO (DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)
-dereferencePtr dbg (CP cp) = run dbg (Closure <$> pure cp <*> GD.dereferenceClosure cp)
-dereferencePtr dbg (SP sc) = run dbg (Stack <$> pure sc <*> GD.dereferenceStack sc)
-
 instance Hextraversable DebugClosure where
-  hextraverse p f g h i j (Closure cp c) = Closure cp <$> hextraverse p f g h i j c
+  hextraverse p f g h i j (Closure cp c cps) = Closure cp <$> hextraverse p f g h i j c <*> pure cps
   hextraverse _ p _ _ _ h (Stack sp s) = Stack sp <$> bitraverse p h s
 
 closureShowAddress :: DebugClosure ccs srt p cd s c -> String
-closureShowAddress (Closure c _) = show c
+closureShowAddress (Closure c _ _) = show c
 closureShowAddress (Stack  (StackCont s _) _) = show s
 
 -- | Get the exclusive size (not including any referenced closures) of a closure.
 closureExclusiveSize :: DebugClosure ccs srt p cd s c -> Size
 closureExclusiveSize (Stack{}) = Size (-1)
-closureExclusiveSize (Closure _ c) = (GD.dcSize c)
+closureExclusiveSize (Closure _ c _) = (GD.dcSize c)
 
 closureSourceLocation :: Debuggee -> DebugClosure ccs srt p cd s c -> IO (Maybe SourceInformation)
 closureSourceLocation _ (Stack _ _) = return Nothing
-closureSourceLocation e (Closure _ c) = run e $ do
+closureSourceLocation e (Closure _ c _) = run e $ do
   request (RequestSourceInfo (tableId (info (noSize c))))
 
 closureInfoPtr :: DebugClosure ccs srt p cd s c -> Maybe InfoTablePtr
 closureInfoPtr (Stack {}) = Nothing
-closureInfoPtr (Closure _ c) = Just (tableId (info (noSize c)))
+closureInfoPtr (Closure _ c _) = Just (tableId (info (noSize c)))
 
 infoSourceLocation :: Debuggee -> InfoTablePtr -> IO (Maybe SourceInformation)
 infoSourceLocation e ip = run e $ request (RequestSourceInfo ip)
@@ -374,7 +369,7 @@ infoSourceLocation e ip = run e $ request (RequestSourceInfo ip)
 closureReferences :: Debuggee -> DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr -> IO [(String, ListItem CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)]
 closureReferences e (Stack _ stack) = run e $ do
   stack' <- bitraverse GD.dereferenceSRT pure stack
-  let action (GD.SPtr ptr) = ("Pointer", ListFullClosure . Closure ptr <$> GD.dereferenceClosure ptr)
+  let action (GD.SPtr ptr) = ("Pointer", ListFullClosure . (\dptr -> Closure ptr dptr []) <$> GD.dereferenceClosure ptr)
       action (GD.SNonPtr dat) = ("Data:" ++ show dat, return ListData)
 
 --      frame_items :: DebugStackFrame
@@ -388,7 +383,7 @@ closureReferences e (Stack _ stack) = run e $ do
             _ -> traverse sequenceA $
 
              ("Info: " ++ show (tableId (frame_info frame)), return (ListOnlyInfo (tableId (frame_info frame)))) :
-             [ ("SRT: ", ListFullClosure . Closure srt <$> GD.dereferenceClosure srt)  | Just srt <- [getSrt (frame_srt frame)]]
+             [ ("SRT: ", ListFullClosure . (\dsrt -> Closure srt dsrt []) <$> GD.dereferenceClosure srt)  | Just srt <- [getSrt (frame_srt frame)]]
              ++ map action (GD.values frame)
 
       add_frame_ix ix (lbl, x) = ("Frame " ++ show ix ++ " " ++ lbl, x)
@@ -401,11 +396,11 @@ closureReferences e (Stack _ stack) = run e $ do
             lblAndPtrs
             closures
             -}
-closureReferences e (Closure _ closure) = run e $ do
+closureReferences e (Closure c closure path) = run e $ do
   closure' <- hextraverse pure GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure
   let wrapClosure cPtr = do
         refClosure' <- GD.dereferenceClosure cPtr
-        return $ ListFullClosure $ Closure cPtr refClosure'
+        return $ ListFullClosure $ Closure cPtr refClosure' (c : path)
       wrapStack sPtr = do
         refStack' <- GD.dereferenceStack sPtr
         return $ ListFullClosure $ Stack sPtr refStack'
@@ -431,33 +426,6 @@ ccsReferences e initialCcs = run e $ (ListCC (ccsCc initialCcs) :) <$> go initia
           children <- go child'
           return (ListCC (ccsCc child') : children)
 
-reverseClosureReferences :: HG.HeapGraph Size
-                         -> HG.ReverseGraph
-                         -> Debuggee
-                         -> DebugClosure CCSPtr HG.SrtHI HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex)
-                         -> IO [(String, DebugClosure
-                                            CCSPtr
-                                            HG.SrtHI
-                                            HG.PapHI
-                                            ConstrDesc HG.StackHI
-                                            (Maybe HG.HeapGraphIndex))]
-reverseClosureReferences hg rm _ c =
-  case c of
-    Stack {} -> error "Nope - Stack"
-    Closure cp _ -> case (HG.reverseEdges cp rm) of
-                      Nothing -> return []
-                      Just es ->
-                        let revs = mapMaybe (flip HG.lookupHeapGraph hg) es
-                        in return [(show n, Closure (HG.hgeClosurePtr hge)
-                                               (DCS (HG.hgeData hge) (HG.hgeClosure hge) ))
-                                    | (n, hge) <- zip [0 :: Int ..] revs]
-
-lookupHeapGraph :: HG.HeapGraph Size -> ClosurePtr -> Maybe (DebugClosure CCSPtr HG.SrtHI HG.PapHI ConstrDesc HG.StackHI (Maybe HG.HeapGraphIndex))
-lookupHeapGraph hg cp =
-  case HG.lookupHeapGraph cp hg of
-    Just (HG.HeapGraphEntry ptr d s) -> Just (Closure ptr (DCS s d))
-    Nothing -> Nothing
-
 fillConstrDesc :: Debuggee
                -> DebugClosure ccs srt pap ConstrDescCont s c
                -> IO (DebugClosure ccs srt pap ConstrDesc s c)
@@ -467,7 +435,7 @@ fillConstrDesc e closure = do
 -- | Pretty print a closure
 closurePretty :: Debuggee -> DebugClosure CCSPtr InfoTablePtr PayloadCont ConstrDesc s ClosurePtr ->  IO String
 closurePretty _ (Stack _ frames) = return $ (show (length frames) ++ " frames")
-closurePretty dbg (Closure _ closure) = run dbg $  do
+closurePretty dbg (Closure _ closure _) = run dbg $  do
   closure' <- hextraverse pure GD.dereferenceSRT GD.dereferencePapPayload pure pure pure closure
   return $ HG.ppClosure
     (\_ refPtr -> show refPtr)
diff --git a/ghc-debug-brick/src/Main.hs b/ghc-debug-brick/src/Main.hs
index f94d754d..f312a80e 100644
--- a/ghc-debug-brick/src/Main.hs
+++ b/ghc-debug-brick/src/Main.hs
@@ -60,7 +60,9 @@ import Data.ByteUnits
 import Data.Time.Format
 import Data.Time.Clock
 import qualified Numeric
-
+import GHC.Debug.StreamedTrace
+import AsyncBuffer
+import GHC.Debug.Client.Monad (unsafeLiftIO)
 
 drawSetup :: Text -> Text -> GenericList Name Seq.Seq SocketInfo -> Widget Name
 drawSetup herald other_herald vals =
@@ -395,7 +397,7 @@ myAppHandleEvent brickEvent = do
             (rootsTree, initRoots) <- liftIO $ mkSavedAndGCRootsIOTree
             put (appState & majorState . mode .~
                         PausedMode
-                          (OperationalState Nothing
+                          (OperationalState NoTask
                                             Nothing
                                             savedAndGCRoots
                                             NoOverlay
@@ -420,11 +422,15 @@ myAppHandleEvent brickEvent = do
               VtyEvent (Vty.EvKey (KEsc) _) | NoOverlay <- view keybindingsMode os
                                             , not (isFocusedFooter (view footerMode os)) -> do
                   case view running_task os of
-                    Just tid -> do
+                    SyncTask tid -> do
                       liftIO $ killThread tid
-                      put $ appState & majorState . mode . pausedMode . running_task .~ Nothing
+                      put $ appState & majorState . mode . pausedMode . running_task .~ NoTask
+                                     & majorState . mode . pausedMode %~ resetFooter
+                    AsyncTask buf -> do
+                      liftIO $ killThread (bufferThread buf)
+                      put $ appState & majorState . mode . pausedMode . running_task .~ NoTask
                                      & majorState . mode . pausedMode %~ resetFooter
-                    Nothing -> do
+                    NoTask -> do
                       liftIO $ resume debuggee'
                       put $ initialAppState (_appChan appState)
 
@@ -451,7 +457,7 @@ getChildren :: Debuggee -> ClosureDetails
 getChildren _ LabelNode{} = return []
 getChildren _ CCDetails {} = return []
 getChildren _ InfoDetails {} = return []
-getChildren d (ClosureDetails c _ _) = do
+getChildren d (ClosureDetails c _ _ _) = do
   children <- closureReferences d c
   children' <- traverse (traverse (fillListItem d)) children
   mapM (\(lbl, child) -> getClosureDetails d (pack lbl) child) children'
@@ -610,11 +616,9 @@ prettyCC :: CCPayload -> Text
 prettyCC Debug.CCPayload{..} =
   T.pack ccLabel <> "   " <> T.pack ccMod <> "   " <> T.pack ccLoc
 
-completeClosureDetails :: Debuggee -> (Text, DebugClosure CCSPtr SrtCont PayloadCont ConstrDescCont StackCont ClosurePtr)
-                                            -> IO ClosureDetails
-
-completeClosureDetails dbg (label', clos)  =
-  getClosureDetails dbg label' . ListFullClosure  =<< fillConstrDesc dbg clos
+completeClosureDetails :: Debuggee -> (Text, Closure) -> IO ClosureDetails
+completeClosureDetails dbg (label', c)  =
+  getClosureDetails dbg label' . ListFullClosure  =<< fillConstrDesc dbg c
 
 
 
@@ -628,7 +632,7 @@ getClosureDetails debuggee' t (ListOnlyInfo info_ptr) = do
 getClosureDetails _ plabel (ListCCS ccs payload) = return $ CCSDetails plabel ccs payload
 getClosureDetails _ plabel (ListCC cc) = return $ CCDetails plabel cc
 getClosureDetails _ t ListData = return $ LabelNode t
-getClosureDetails debuggee' label' (ListFullClosure c) = do
+getClosureDetails debuggee' label' (ListFullClosure c@(Closure _ _ parents)) = do
   let excSize' = closureExclusiveSize c
   sourceLoc <- maybe (return Nothing) (infoSourceLocation debuggee') (closureInfoPtr c)
   pretty' <- closurePretty debuggee' c
@@ -645,6 +649,7 @@ getClosureDetails debuggee' label' (ListFullClosure c) = do
           _ -> Nothing
       }
     , _excSize = excSize'
+    , _closureParents = parents
     }
 
 getInfoInfo :: Debuggee -> Text -> InfoTablePtr -> IO InfoInfo
@@ -670,17 +675,33 @@ handleMain :: Debuggee -> Handler Event OperationalState
 handleMain dbg e = do
   os <- get
   case e of
-    AppEvent event -> case event of
-            PollTick -> return ()
+    AppEvent event ->
+      case event of
+            PollTick -> do
+              case view running_task os of
+                NoTask -> return ()
+                SyncTask _ -> return ()
+                AsyncTask buf -> do
+                  case view treeMode os of
+                    Retainer r tree -> do
+                      v <- liftIO $ tryReadMVar (bufferStatus buf)
+                      xs <- liftIO $ sampleAsyncBuffer buf
+                      let newTree = addIOTreeRoots tree xs
+                      case v of
+                        Just _ -> put $ resetFooter os & running_task .~ NoTask
+                                       & treeMode .~ (Retainer r newTree)
+                        Nothing -> put $ resetFooter os & treeMode .~ (Retainer r newTree)
+                    _ -> return  ()
             ProgressMessage t -> do
               put $ footerMessage t os
             ProgressFinished desc runtime ->
               put $ os
-                    & running_task .~ Nothing
+                    & running_task .~ NoTask
                     & last_run_time .~ Just (desc, runtime)
                     & footerMode .~ FooterInfo
             AsyncFinished action -> action
-    _ | Nothing <- view running_task os ->
+    -- _ | { NoTask <- view running_task os ->
+    _ ->
       case view keybindingsMode os of
         KeybindingsShown ->
           case e of
@@ -732,7 +753,6 @@ handleMain dbg e = do
         NoOverlay -> case view footerMode os of
           FooterInput fm form -> inputFooterHandler dbg fm form (handleMainWindowEvent dbg) (() <$ e)
           _ -> handleMainWindowEvent dbg (() <$ e)
-    _ -> return ()
 
 commandPickerMode :: OverlayMode
 commandPickerMode =
@@ -873,7 +893,7 @@ stringsAction dbg = do
           let Just cs = M.lookup b res
           cs' <- run dbg $ forM (S.toList cs) $ \c -> do
             c' <- GD.dereferenceClosure c
-            return $ ListFullClosure $ Closure c c'
+            return $ ListFullClosure $ Closure c c' []
           children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs'
           mapM (\(lbl, child) -> FieldLine <$> getClosureDetails d (pack lbl) child) children'
         g_children d (FieldLine c) = map FieldLine <$> getChildren d c
@@ -946,7 +966,7 @@ arrWordsAction dbg = do
           let Just cs = M.lookup b res
           cs' <- run dbg $ forM (S.toList cs) $ \c -> do
             c' <- GD.dereferenceClosure c
-            return $ ListFullClosure $ Closure c c'
+            return $ ListFullClosure $ Closure c c' []
           children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs'
           mapM (\(lbl, child) -> FieldLine <$> getClosureDetails d (pack lbl) child) children'
         g_children d (FieldLine c) = map FieldLine <$> getChildren d c
@@ -997,16 +1017,13 @@ thunkAnalysisAction dbg = do
 
 searchWithCurrentFilters :: Debuggee -> EventM n OperationalState ()
 searchWithCurrentFilters dbg = do
-  outside_os <- get
-  let mClosFilter = uiFiltersToFilter (_filters outside_os)
-  asyncAction "Searching for closures" outside_os (liftIO $ retainersOf (_resultSize outside_os) mClosFilter Nothing dbg) $ \cps -> do
-    os <- get
-    let cps' = map (zipWith (\n cp -> (T.pack (show n),cp)) [0 :: Int ..]) cps
-    res <- liftIO $ mapM (mapM (completeClosureDetails dbg)) cps'
-    let tree = mkRetainerTree dbg res
-    put (os & resetFooter
-            & treeMode .~ Retainer renderClosureDetails tree
-        )
+  os <- get
+  let mClosFilter = uiFiltersToFilter (_filters os)
+  str <- liftIO $ retainersOf (_resultSize os) mClosFilter Nothing dbg
+  buf <- liftIO $ streamBuffer dbg $ flip mapMStream str $ \c -> unsafeLiftIO $ completeClosureDetails dbg ("1", c)
+  put $ footerMessage "Searching for closures" os
+      & running_task .~ AsyncTask buf
+      & treeMode .~ Retainer renderClosureDetails (emptyRetainerTree dbg)
 
 filterOrRun :: Debuggee -> Form Text () Name -> Bool -> (String -> Maybe a) -> (a -> [UIFilter]) -> EventM n OperationalState ()
 filterOrRun dbg form doRun parse createFilter =
@@ -1077,7 +1094,7 @@ dispatchFooterInput dbg (FProfile lvl) form = do
           let cs = getSamples (sample stats)
           cs' <- run dbg $ forM cs $ \c -> do
             c' <- GD.dereferenceClosure c
-            return $ ListFullClosure $ Closure c c'
+            return $ ListFullClosure $ Closure c c' []
           children' <- traverse (traverse (fillListItem d)) $ zipWith (\n c -> (show @Int n, c)) [0..] cs'
           mapM (\(lbl, child) -> ClosureLine <$> getClosureDetails d (pack lbl) child) children'
 
@@ -1146,32 +1163,22 @@ asyncAction desc os action final = do
     end <- getCurrentTime
     writeBChan eventChan (AsyncFinished (final res))
     writeBChan eventChan (ProgressFinished desc (end `diffUTCTime` start)))
-  put $ os & running_task .~ Just tid
+  put $ os & running_task .~ SyncTask tid
            & resetFooter
   where
     eventChan = view event_chan os
 
 
 
-mkRetainerTree :: Debuggee -> [[ClosureDetails]] -> IOTree ClosureDetails Name
-mkRetainerTree dbg stacks = do
-  let stack_map = [ (cp, rest) | stack <- stacks, Just (cp, rest) <- [List.uncons stack]]
-      roots = map fst stack_map
-      info_map :: M.Map Ptr [(Text, (DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr))]
-      info_map = M.fromList [(toPtr (_closure k), zipWith (\n cp -> ((T.pack (show n)), (_closure cp))) [0 :: Int ..] v) | (k, v) <- stack_map]
-
-      lookup_c dbg' dc'@(ClosureDetails dc _ _) = do
-        let ptr = toPtr dc
-            results = M.findWithDefault [] ptr info_map
-        -- We are also looking up the children of the object we are retaining,
-        -- and displaying them prior to the retainer stack
-        cs <- getChildren dbg' dc'
-        results' <- liftIO $ mapM (\(l, c) -> getClosureDetails dbg' l (ListFullClosure c)) results
-        return (cs ++ results')
-      -- And if it's not a closure, just do the normal thing
-      lookup_c dbg' dc' = getChildren dbg' dc'
-
-  mkIOTree dbg roots lookup_c renderInlineClosureDesc id
+emptyRetainerTree :: Debuggee -> IOTree ClosureDetails Name
+emptyRetainerTree dbg = do
+  let lookup_c dbg dc'@(ClosureDetails _ _ _ parents) = do
+        cs <- getChildren dbg dc'
+        results <- liftIO $ forM (zip3 [0..] parents (drop 1 $ List.tails parents)) $ \(i, cp, cps) -> do
+          c <- run dbg $ GD.dereferenceClosure cp
+          completeClosureDetails dbg (T.pack (show i), Closure cp c cps)
+        return (cs ++ results)
+  mkIOTree dbg [] lookup_c renderInlineClosureDesc id
 
 resetFooter :: OperationalState -> OperationalState
 resetFooter l = (set footerMode FooterInfo l)
diff --git a/ghc-debug-brick/src/Model.hs b/ghc-debug-brick/src/Model.hs
index 8dca04fd..bac60c51 100644
--- a/ghc-debug-brick/src/Model.hs
+++ b/ghc-debug-brick/src/Model.hs
@@ -34,6 +34,7 @@ import Namespace
 import Common
 import Lib
 import IOTree
+import AsyncBuffer
 import Control.Concurrent
 import qualified Graphics.Vty as Vty
 import Data.Int
@@ -50,7 +51,6 @@ data Event
   | ProgressFinished Text NominalDiffTime
   | AsyncFinished (EventM Name OperationalState ())
 
-
 initialAppState :: BChan Event -> AppState
 initialAppState event = AppState
   { _majorState = Setup
@@ -123,6 +123,7 @@ data ClosureDetails = ClosureDetails
   { _closure :: DebugClosure CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
   , _excSize :: Size
   , _info :: InfoInfo
+  , _closureParents :: [ClosurePtr]
   }
   | InfoDetails { _info :: InfoInfo }
   | CCSDetails Text CCSPtr (GenCCSPayload CCSPtr CCPayload)
@@ -246,8 +247,13 @@ currentRoots :: RootsOrigin -> [(Text, Ptr)]
 currentRoots (DefaultRoots cp) = cp
 currentRoots (SearchedRoots cp) = cp
 
+data TaskState
+  = NoTask
+  | SyncTask ThreadId
+  | AsyncTask (AsyncBuffer ClosureDetails () (Maybe ()))
+
 data OperationalState = OperationalState
-    { _running_task :: Maybe ThreadId
+    { _running_task :: TaskState
     , _last_run_time :: Maybe (Text, NominalDiffTime)
     , _treeMode :: TreeMode
     , _keybindingsMode :: OverlayMode
-- 
GitLab