module GHC.Debug.Retainers(findRetainersOf, findRetainers, addLocationToStack, displayRetainerStack) where
import GHC.Debug.Client
import Control.Monad.State
import GHC.Debug.Trace
import GHC.Debug.Types.Graph
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 (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
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 (m :: * -> *) a. Monad m => a -> m a
return ())
, stackTrace :: GenStackFrames ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
stackTrace = RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> GenStackFrames ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
forall a b. a -> b -> a
const (() -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
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 (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 (m :: * -> *) a. Monad m => a -> m a
return ())
}
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
cp SizedClosure
sc RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
k = do
Bool
b <- DebugM Bool
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM Bool
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))
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 (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 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 [(SizedClosureC, Maybe SourceInformation)]
addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureC, Maybe SourceInformation)]
addLocationToStack [ClosurePtr]
r = do
[SizedClosure]
cs <- [ClosurePtr] -> DebugM [SizedClosure]
dereferenceClosures [ClosurePtr]
r
[SizedClosureC]
cs' <- (SizedClosure -> DebugM SizedClosureC)
-> [SizedClosure] -> DebugM [SizedClosureC]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((PayloadCont -> DebugM PayloadCont)
-> (ConstrDescCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM SizedClosureC
forall (m :: * -> * -> * -> * -> *) (f :: * -> *) a b c d e g h i.
(Quadtraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> m a c e h
-> f (m b d g i)
quadtraverse PayloadCont -> DebugM PayloadCont
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosurePtr -> DebugM ClosurePtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [SizedClosure]
cs
[Maybe SourceInformation]
locs <- (SizedClosureC -> DebugM (Maybe SourceInformation))
-> [SizedClosureC] -> DebugM [Maybe SourceInformation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SizedClosureC -> DebugM (Maybe SourceInformation)
forall {pap} {string} {s} {b}.
DebugClosureWithSize pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc [SizedClosureC]
cs'
return $ ([SizedClosureC]
-> [Maybe SourceInformation]
-> [(SizedClosureC, Maybe SourceInformation)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SizedClosureC]
cs' [Maybe SourceInformation]
locs)
where
getSourceLoc :: DebugClosureWithSize pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc DebugClosureWithSize pap string s b
c = ConstrDescCont -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> ConstrDescCont
tableId (DebugClosure pap string s b -> StgInfoTableWithPtr
forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (DebugClosureWithSize pap string s b -> DebugClosure pap string s b
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize DebugClosureWithSize pap string s b
c)))
displayRetainerStack :: [(String, [(SizedClosureC, Maybe SourceInformation)])] -> IO ()
displayRetainerStack :: [(String, [(SizedClosureC, Maybe SourceInformation)])] -> IO ()
displayRetainerStack [(String, [(SizedClosureC, Maybe SourceInformation)])]
rs = do
let disp :: (DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
-> String
disp (DebugClosureWithSize p ConstrDesc s c
d, Maybe SourceInformation
l) =
(String
-> (Int -> c -> String)
-> Int
-> DebugClosure p ConstrDesc s c
-> String
forall c p s.
String
-> (Int -> c -> String)
-> Int
-> DebugClosure p ConstrDesc s c
-> String
ppClosure String
"" (\Int
_ -> c -> String
forall a. Show a => a -> String
show) Int
0 (DebugClosure p ConstrDesc s c -> String)
-> (DebugClosureWithSize p ConstrDesc s c
-> DebugClosure p ConstrDesc s c)
-> DebugClosureWithSize p ConstrDesc s c
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosureWithSize p ConstrDesc s c
-> DebugClosure p ConstrDesc s c
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize (DebugClosureWithSize p ConstrDesc s c -> String)
-> DebugClosureWithSize p ConstrDesc s c -> String
forall a b. (a -> b) -> a -> b
$ DebugClosureWithSize 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
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 p ConstrDesc s c, Maybe SourceInformation))
-> IO (t ())
do_one a
k (a
l, t (DebugClosureWithSize 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 p ConstrDesc s c, Maybe SourceInformation)
-> IO ())
-> t (DebugClosureWithSize 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)
mapM (String -> IO ()
putStrLn (String -> IO ())
-> ((DebugClosureWithSize p ConstrDesc s c,
Maybe SourceInformation)
-> String)
-> (DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
-> String
forall {c} {p} {s}.
Show c =>
(DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
-> String
disp) t (DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation)
stack
(Int
-> (String, [(SizedClosureC, Maybe SourceInformation)]) -> IO [()])
-> [Int]
-> [(String, [(SizedClosureC, Maybe SourceInformation)])]
-> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Int
-> (String, [(SizedClosureC, Maybe SourceInformation)]) -> IO [()]
forall {t :: * -> *} {a} {a} {c} {p} {s}.
(Traversable t, Show a, Show a, Show c) =>
a
-> (a,
t (DebugClosureWithSize p ConstrDesc s c, Maybe SourceInformation))
-> IO (t ())
do_one [Int
0 :: Int ..] [(String, [(SizedClosureC, Maybe SourceInformation)])]
rs