{-# LANGUAGE ViewPatterns #-}
-- | Functions for computing retainers
module GHC.Debug.Retainers(findRetainersOf, findRetainersOfConstructor, findRetainersOfConstructorExact, findRetainersOfInfoTable, findRetainers, addLocationToStack, displayRetainerStack, addLocationToStack', displayRetainerStack') where

import GHC.Debug.Client
import Control.Monad.State
import GHC.Debug.Trace
import GHC.Debug.Types.Graph
import Control.Monad

import qualified Data.Set as Set
import Control.Monad.RWS

addOne :: [ClosurePtr] -> (Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]])
addOne :: [ClosurePtr]
-> (Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]])
addOne [ClosurePtr]
_ (Just Int
0, [[ClosurePtr]]
cp) = (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0, [[ClosurePtr]]
cp)
addOne [ClosurePtr]
cp (Maybe Int
n, [[ClosurePtr]]
cps)    = (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
n, [ClosurePtr]
cp[ClosurePtr] -> [[ClosurePtr]] -> [[ClosurePtr]]
forall a. a -> [a] -> [a]
:[[ClosurePtr]]
cps)

findRetainersOf :: Maybe Int
                -> [ClosurePtr]
                -> [ClosurePtr]
                -> DebugM [[ClosurePtr]]
findRetainersOf :: Maybe Int -> [ClosurePtr] -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainersOf Maybe Int
limit [ClosurePtr]
cps [ClosurePtr]
bads = Maybe Int
-> [ClosurePtr]
-> (ClosurePtr -> SizedClosure -> DebugM Bool)
-> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit [ClosurePtr]
cps (\ClosurePtr
cp SizedClosure
_ -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClosurePtr
cp ClosurePtr -> Set ClosurePtr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ClosurePtr
bad_set))
  where
    bad_set :: Set ClosurePtr
bad_set = [ClosurePtr] -> Set ClosurePtr
forall a. Ord a => [a] -> Set a
Set.fromList [ClosurePtr]
bads

findRetainersOfConstructor :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
findRetainersOfConstructor :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
findRetainersOfConstructor Maybe Int
limit [ClosurePtr]
rroots String
con_name =
  Maybe Int
-> [ClosurePtr]
-> (ClosurePtr -> SizedClosure -> DebugM Bool)
-> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit [ClosurePtr]
rroots ClosurePtr -> SizedClosure -> DebugM Bool
forall {p} {srt} {pap} {s} {b}.
p -> DebugClosureWithSize srt pap ConstrDescCont s b -> DebugM Bool
go
  where
    go :: p -> DebugClosureWithSize srt pap ConstrDescCont s b -> DebugM Bool
go p
_ DebugClosureWithSize srt pap ConstrDescCont s b
sc =
      case DebugClosureWithSize srt pap ConstrDescCont s b
-> DebugClosure srt pap ConstrDescCont s b
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithSize srt pap ConstrDescCont s b
sc of
        ConstrClosure StgInfoTableWithPtr
_ [b]
_ [Word]
_ ConstrDescCont
cd -> do
          ConstrDesc String
_ String
_  String
cname <- ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc ConstrDescCont
cd
          Bool -> DebugM Bool
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> DebugM Bool) -> Bool -> DebugM Bool
forall a b. (a -> b) -> a -> b
$ String
cname String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
con_name
        DebugClosure srt pap ConstrDescCont s b
_ -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> DebugM Bool) -> Bool -> DebugM Bool
forall a b. (a -> b) -> a -> b
$ Bool
False

findRetainersOfConstructorExact :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
findRetainersOfConstructorExact :: Maybe Int -> [ClosurePtr] -> String -> DebugM [[ClosurePtr]]
findRetainersOfConstructorExact Maybe Int
limit [ClosurePtr]
rroots String
clos_name =
  Maybe Int
-> [ClosurePtr]
-> (ClosurePtr -> SizedClosure -> DebugM Bool)
-> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit [ClosurePtr]
rroots ClosurePtr -> SizedClosure -> DebugM Bool
forall {p} {srt} {pap} {string} {s} {b}.
p -> DebugClosureWithSize srt pap string s b -> DebugM Bool
go
  where
    go :: p -> DebugClosureWithSize srt pap string s b -> DebugM Bool
go p
_ DebugClosureWithSize srt pap string s b
sc = do
      Maybe SourceInformation
loc <- ConstrDescCont -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> ConstrDescCont
tableId (DebugClosure srt pap string s b -> StgInfoTableWithPtr
forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info (DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithSize srt pap string s b
sc)))
      case Maybe SourceInformation
loc of
        Maybe SourceInformation
Nothing -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just SourceInformation
cur_loc ->

          Bool -> DebugM Bool
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> DebugM Bool) -> Bool -> DebugM Bool
forall a b. (a -> b) -> a -> b
$ (SourceInformation -> String
infoName SourceInformation
cur_loc) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
clos_name

findRetainersOfInfoTable :: Maybe Int -> [ClosurePtr] -> InfoTablePtr -> DebugM [[ClosurePtr]]
findRetainersOfInfoTable :: Maybe Int
-> [ClosurePtr] -> ConstrDescCont -> DebugM [[ClosurePtr]]
findRetainersOfInfoTable Maybe Int
limit [ClosurePtr]
rroots ConstrDescCont
info_ptr =
  Maybe Int
-> [ClosurePtr]
-> (ClosurePtr -> SizedClosure -> DebugM Bool)
-> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit [ClosurePtr]
rroots ClosurePtr -> SizedClosure -> DebugM Bool
forall {m :: * -> *} {p} {srt} {pap} {string} {s} {b}.
Monad m =>
p -> DebugClosureWithSize srt pap string s b -> m Bool
go
  where
    go :: p -> DebugClosureWithSize srt pap string s b -> m Bool
go p
_ DebugClosureWithSize srt pap string s b
sc = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ StgInfoTableWithPtr -> ConstrDescCont
tableId (DebugClosure srt pap string s b -> StgInfoTableWithPtr
forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info (DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithSize srt pap string s b
sc)) ConstrDescCont -> ConstrDescCont -> Bool
forall a. Eq a => a -> a -> Bool
== ConstrDescCont
info_ptr

-- | From the given roots, find any path to one of the given pointers.
-- Note: This function can be quite slow! The first argument is a limit to
-- how many paths to find. You should normally set this to a small number
-- such as 10.
findRetainers :: Maybe Int -> [ClosurePtr] -> (ClosurePtr -> SizedClosure -> DebugM Bool) -> DebugM [[ClosurePtr]]
findRetainers :: Maybe Int
-> [ClosurePtr]
-> (ClosurePtr -> SizedClosure -> DebugM Bool)
-> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit [ClosurePtr]
rroots ClosurePtr -> SizedClosure -> DebugM Bool
p = (\(()
_, (Maybe Int, [[ClosurePtr]])
r, ()
_) -> (Maybe Int, [[ClosurePtr]]) -> [[ClosurePtr]]
forall a b. (a, b) -> b
snd (Maybe Int, [[ClosurePtr]])
r) (((), (Maybe Int, [[ClosurePtr]]), ()) -> [[ClosurePtr]])
-> DebugM ((), (Maybe Int, [[ClosurePtr]]), ())
-> DebugM [[ClosurePtr]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> [ClosurePtr]
-> (Maybe Int, [[ClosurePtr]])
-> DebugM ((), (Maybe Int, [[ClosurePtr]]), ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (TraceFunctions (RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]))
-> [ClosurePtr]
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m -> [ClosurePtr] -> m DebugM ()
traceFromM TraceFunctions (RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]))
funcs [ClosurePtr]
rroots) [] (Maybe Int
limit, [])
  where
    funcs :: TraceFunctions (RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]))
funcs = TraceFunctions {
               papTrace :: GenPapPayload ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
papTrace = RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> GenPapPayload ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a b. a -> b -> a
const (() -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a.
a -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , srtTrace :: GenSrtPayload ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
srtTrace = RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> GenSrtPayload ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a b. a -> b -> a
const (() -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a.
a -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , stackTrace :: GenStackFrames ConstrDescCont ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
stackTrace = RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> GenStackFrames ConstrDescCont ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a b. a -> b -> a
const (() -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a.
a -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , closTrace :: ClosurePtr
-> SizedClosure
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
closTrace = ClosurePtr
-> SizedClosure
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
closAccum
              , visitedVal :: ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
visitedVal = RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a b. a -> b -> a
const (() -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a.
a -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , conDescTrace :: ConstrDesc
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
conDescTrace = RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> ConstrDesc
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a b. a -> b -> a
const (() -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a.
a -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

            }
    -- Add clos
    closAccum  :: ClosurePtr
               -> SizedClosure
               -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
               -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
    closAccum :: ClosurePtr
-> SizedClosure
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
closAccum ClosurePtr
_ (SizedClosure
-> DebugClosure
     ConstrDescCont PayloadCont ConstrDescCont StackCont ClosurePtr
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize -> WeakClosure {}) RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
_ = () -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a.
a -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    closAccum ClosurePtr
cp SizedClosure
sc RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
k = do
      Bool
b <- DebugM Bool
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM Bool
forall (m :: * -> *) a.
Monad m =>
m a -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM Bool
 -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM Bool)
-> DebugM Bool
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM Bool
forall a b. (a -> b) -> a -> b
$ ClosurePtr -> SizedClosure -> DebugM Bool
p ClosurePtr
cp SizedClosure
sc
      if Bool
b
        then do
          [ClosurePtr]
ctx <- RWST
  [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM [ClosurePtr]
forall r (m :: * -> *). MonadReader r m => m r
ask
          ((Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]]))
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ([ClosurePtr]
-> (Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]])
addOne (ClosurePtr
cpClosurePtr -> [ClosurePtr] -> [ClosurePtr]
forall a. a -> [a] -> [a]
: [ClosurePtr]
ctx))
          ([ClosurePtr] -> [ClosurePtr])
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a.
([ClosurePtr] -> [ClosurePtr])
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM a
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ClosurePtr
cpClosurePtr -> [ClosurePtr] -> [ClosurePtr]
forall a. a -> [a] -> [a]
:) RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
k
          -- Don't call k, there might be more paths to the pointer but we
          -- probably just care about this first one.
        else do
          (Maybe Int
lim, [[ClosurePtr]]
_) <- RWST
  [ClosurePtr]
  ()
  (Maybe Int, [[ClosurePtr]])
  DebugM
  (Maybe Int, [[ClosurePtr]])
forall s (m :: * -> *). MonadState s m => m s
get
          case Maybe Int
lim of
            Just Int
0 -> () -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a.
a -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Maybe Int
_ -> ([ClosurePtr] -> [ClosurePtr])
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a.
([ClosurePtr] -> [ClosurePtr])
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM a
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ClosurePtr
cpClosurePtr -> [ClosurePtr] -> [ClosurePtr]
forall a. a -> [a] -> [a]
:) RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
k

addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureP, Maybe SourceInformation)]
addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureP, Maybe SourceInformation)]
addLocationToStack [ClosurePtr]
r = do
  [SizedClosure]
cs <- [ClosurePtr] -> DebugM [SizedClosure]
dereferenceClosures [ClosurePtr]
r
  [SizedClosureP]
cs' <- (SizedClosure -> DebugM SizedClosureP)
-> [SizedClosure] -> DebugM [SizedClosureP]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SizedClosure -> DebugM SizedClosureP
dereferenceToClosurePtr [SizedClosure]
cs
  [Maybe SourceInformation]
locs <- (SizedClosureP -> DebugM (Maybe SourceInformation))
-> [SizedClosureP] -> DebugM [Maybe SourceInformation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SizedClosureP -> DebugM (Maybe SourceInformation)
forall {srt} {pap} {string} {s} {b}.
DebugClosureWithSize srt pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc [SizedClosureP]
cs'
  return $ ([SizedClosureP]
-> [Maybe SourceInformation]
-> [(SizedClosureP, Maybe SourceInformation)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SizedClosureP]
cs' [Maybe SourceInformation]
locs)
  where
    getSourceLoc :: DebugClosureWithSize srt pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc DebugClosureWithSize srt pap string s b
c = ConstrDescCont -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> ConstrDescCont
tableId (DebugClosure srt pap string s b -> StgInfoTableWithPtr
forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info (DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithSize srt pap string s b
c)))

addLocationToStack' :: [ClosurePtr] -> DebugM [(ClosurePtr, SizedClosureP, Maybe SourceInformation)]
addLocationToStack' :: [ClosurePtr]
-> DebugM [(ClosurePtr, SizedClosureP, Maybe SourceInformation)]
addLocationToStack' [ClosurePtr]
r = do
  [SizedClosure]
cs <- [ClosurePtr] -> DebugM [SizedClosure]
dereferenceClosures [ClosurePtr]
r
  [SizedClosureP]
cs' <- (SizedClosure -> DebugM SizedClosureP)
-> [SizedClosure] -> DebugM [SizedClosureP]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SizedClosure -> DebugM SizedClosureP
dereferenceToClosurePtr [SizedClosure]
cs
  [Maybe SourceInformation]
locs <- (SizedClosureP -> DebugM (Maybe SourceInformation))
-> [SizedClosureP] -> DebugM [Maybe SourceInformation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SizedClosureP -> DebugM (Maybe SourceInformation)
forall {srt} {pap} {string} {s} {b}.
DebugClosureWithSize srt pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc [SizedClosureP]
cs'
  return $ ([ClosurePtr]
-> [SizedClosureP]
-> [Maybe SourceInformation]
-> [(ClosurePtr, SizedClosureP, Maybe SourceInformation)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [ClosurePtr]
r [SizedClosureP]
cs' [Maybe SourceInformation]
locs)
  where
    getSourceLoc :: DebugClosureWithSize srt pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc DebugClosureWithSize srt pap string s b
c = ConstrDescCont -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> ConstrDescCont
tableId (DebugClosure srt pap string s b -> StgInfoTableWithPtr
forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info (DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithSize srt pap string s b
c)))

displayRetainerStack :: [(String, [(SizedClosureP, Maybe SourceInformation)])] -> IO ()
displayRetainerStack :: [(String, [(SizedClosureP, Maybe SourceInformation)])] -> IO ()
displayRetainerStack [(String, [(SizedClosureP, Maybe SourceInformation)])]
rs = do
      let disp :: (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
 Maybe SourceInformation)
-> String
disp (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
d, Maybe SourceInformation
l) =
            ((Int -> c -> String)
-> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
forall c p s.
(Int -> c -> String)
-> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
ppClosure  (\Int
_ -> c -> String
forall a. Show a => a -> String
show) Int
0 (DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String)
-> (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
    -> DebugClosure (GenSrtPayload c) p ConstrDesc s c)
-> DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
-> DebugClosure (GenSrtPayload c) p ConstrDesc s c
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c -> String)
-> DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
-> String
forall a b. (a -> b) -> a -> b
$ DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
d) String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
" <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> (SourceInformation -> String)
-> Maybe SourceInformation
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"nl" SourceInformation -> String
tdisplay Maybe SourceInformation
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
            where
              tdisplay :: SourceInformation -> String
tdisplay SourceInformation
sl = SourceInformation -> String
infoName SourceInformation
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoType SourceInformation
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoModule SourceInformation
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoPosition SourceInformation
sl
          do_one :: a
-> (a,
    t (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
       Maybe SourceInformation))
-> IO (t ())
do_one a
k (a
l, t (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
   Maybe SourceInformation)
stack) = do
            String -> IO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-------------------------------------")
            a -> IO ()
forall a. Show a => a -> IO ()
print a
l
            ((DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
  Maybe SourceInformation)
 -> IO ())
-> t (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
      Maybe SourceInformation)
-> IO (t ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM (String -> IO ()
putStrLn (String -> IO ())
-> ((DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
     Maybe SourceInformation)
    -> String)
-> (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
    Maybe SourceInformation)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
 Maybe SourceInformation)
-> String
forall {c} {p} {s}.
Show c =>
(DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
 Maybe SourceInformation)
-> String
disp) t (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
   Maybe SourceInformation)
stack
      (Int
 -> (String, [(SizedClosureP, Maybe SourceInformation)]) -> IO [()])
-> [Int]
-> [(String, [(SizedClosureP, Maybe SourceInformation)])]
-> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Int
-> (String, [(SizedClosureP, Maybe SourceInformation)]) -> IO [()]
forall {t :: * -> *} {a} {a} {c} {p} {s}.
(Traversable t, Show a, Show a, Show c) =>
a
-> (a,
    t (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
       Maybe SourceInformation))
-> IO (t ())
do_one [Int
0 :: Int ..] [(String, [(SizedClosureP, Maybe SourceInformation)])]
rs

displayRetainerStack' :: [(String, [(ClosurePtr, SizedClosureP, Maybe SourceInformation)])] -> IO ()
displayRetainerStack' :: [(String, [(ClosurePtr, SizedClosureP, Maybe SourceInformation)])]
-> IO ()
displayRetainerStack' [(String, [(ClosurePtr, SizedClosureP, Maybe SourceInformation)])]
rs = do
      let disp :: (a, DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
 Maybe SourceInformation)
-> String
disp (a
p, DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
d, Maybe SourceInformation
l) =
            a -> String
forall a. Show a => a -> String
show a
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ((Int -> c -> String)
-> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
forall c p s.
(Int -> c -> String)
-> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
ppClosure  (\Int
_ -> c -> String
forall a. Show a => a -> String
show) Int
0 (DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String)
-> (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
    -> DebugClosure (GenSrtPayload c) p ConstrDesc s c)
-> DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
-> DebugClosure (GenSrtPayload c) p ConstrDesc s c
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize (DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c -> String)
-> DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
-> String
forall a b. (a -> b) -> a -> b
$ DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
d) String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
" <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> (SourceInformation -> String)
-> Maybe SourceInformation
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"nl" SourceInformation -> String
tdisplay Maybe SourceInformation
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
            where
              tdisplay :: SourceInformation -> String
tdisplay SourceInformation
sl = SourceInformation -> String
infoName SourceInformation
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoType SourceInformation
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoModule SourceInformation
sl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoPosition SourceInformation
sl
          do_one :: a
-> (a,
    t (a, DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
       Maybe SourceInformation))
-> IO (t ())
do_one a
k (a
l, t (a, DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
   Maybe SourceInformation)
stack) = do
            String -> IO ()
putStrLn (a -> String
forall a. Show a => a -> String
show a
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-------------------------------------")
            a -> IO ()
forall a. Show a => a -> IO ()
print a
l
            ((a, DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
  Maybe SourceInformation)
 -> IO ())
-> t (a, DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
      Maybe SourceInformation)
-> IO (t ())
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM (String -> IO ()
putStrLn (String -> IO ())
-> ((a, DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
     Maybe SourceInformation)
    -> String)
-> (a, DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
    Maybe SourceInformation)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
 Maybe SourceInformation)
-> String
forall {a} {c} {p} {s}.
(Show a, Show c) =>
(a, DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
 Maybe SourceInformation)
-> String
disp) t (a, DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
   Maybe SourceInformation)
stack
      (Int
 -> (String, [(ClosurePtr, SizedClosureP, Maybe SourceInformation)])
 -> IO [()])
-> [Int]
-> [(String,
     [(ClosurePtr, SizedClosureP, Maybe SourceInformation)])]
-> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Int
-> (String, [(ClosurePtr, SizedClosureP, Maybe SourceInformation)])
-> IO [()]
forall {t :: * -> *} {a} {a} {a} {c} {p} {s}.
(Traversable t, Show a, Show a, Show a, Show c) =>
a
-> (a,
    t (a, DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c,
       Maybe SourceInformation))
-> IO (t ())
do_one [Int
0 :: Int ..] [(String, [(ClosurePtr, SizedClosureP, Maybe SourceInformation)])]
rs