{-# LANGUAGE ViewPatterns #-}
-- | Functions for computing retainers
module GHC.Debug.Retainers(findRetainersOf, findRetainersOfConstructor, findRetainersOfConstructorExact, findRetainers, addLocationToStack, displayRetainerStack, 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) = (forall a. a -> Maybe a
Just Int
0, [[ClosurePtr]]
cp)
addOne [ClosurePtr]
cp (Maybe Int
n, [[ClosurePtr]]
cps)    = (forall a. Num a => a -> a -> a
subtract Int
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
n, [ClosurePtr]
cpforall 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (ClosurePtr
cp forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ClosurePtr
bad_set))
  where
    bad_set :: Set ClosurePtr
bad_set = 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 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 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
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
cname forall a. Eq a => a -> a -> Bool
== String
con_name
        DebugClosure srt pap ConstrDescCont s b
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 (forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just SourceInformation
cur_loc ->

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

-- | 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, ()
_) -> forall a b. (a, b) -> b
snd (Maybe Int, [[ClosurePtr]])
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (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 = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , srtTrace :: GenSrtPayload ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
srtTrace = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , stackTrace :: GenStackFrames ConstrDescCont ClosurePtr
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
stackTrace = forall a b. a -> b -> a
const (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 = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , conDescTrace :: ConstrDesc
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
conDescTrace = forall a b. a -> b -> a
const (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
_ (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 ()
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    closAccum ClosurePtr
cp SizedClosure
sc RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
k = do
      Bool
b <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ClosurePtr -> SizedClosure -> DebugM Bool
p ClosurePtr
cp SizedClosure
sc
      if Bool
b
        then do
          [ClosurePtr]
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ([ClosurePtr]
-> (Maybe Int, [[ClosurePtr]]) -> (Maybe Int, [[ClosurePtr]])
addOne (ClosurePtr
cpforall a. a -> [a] -> [a]
: [ClosurePtr]
ctx))
          forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ClosurePtr
cpforall 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]]
_) <- forall s (m :: * -> *). MonadState s m => m s
get
          case Maybe Int
lim of
            Just Int
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Maybe Int
_ -> forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ClosurePtr
cpforall 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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SizedClosure -> DebugM SizedClosureP
dereferenceToClosurePtr [SizedClosure]
cs
  [Maybe SourceInformation]
locs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {srt} {pap} {string} {s} {b}.
DebugClosureWithSize srt pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc [SizedClosureP]
cs'
  return $ (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 (forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info (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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SizedClosure -> DebugM SizedClosureP
dereferenceToClosurePtr [SizedClosure]
cs
  [Maybe SourceInformation]
locs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {srt} {pap} {string} {s} {b}.
DebugClosureWithSize srt pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc [SizedClosureP]
cs'
  return $ (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 (forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info (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) =
            (forall c p s.
(Int -> c -> String)
-> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
ppClosure  (\Int
_ -> forall a. Show a => a -> String
show) Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize forall a b. (a -> b) -> a -> b
$ DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
d) forall a. [a] -> [a] -> [a]
++  String
" <" forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"nl" SourceInformation -> String
tdisplay Maybe SourceInformation
l forall a. [a] -> [a] -> [a]
++ String
">"
            where
              tdisplay :: SourceInformation -> String
tdisplay SourceInformation
sl = SourceInformation -> String
infoName SourceInformation
sl forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoType SourceInformation
sl forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoModule SourceInformation
sl forall a. [a] -> [a] -> [a]
++ 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 (forall a. Show a => a -> String
show a
k forall a. [a] -> [a] -> [a]
++ String
"-------------------------------------")
            forall a. Show a => a -> IO ()
print a
l
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
      forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ 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) =
            forall a. Show a => a -> String
show a
p forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ (forall c p s.
(Int -> c -> String)
-> Int -> DebugClosure (GenSrtPayload c) p ConstrDesc s c -> String
ppClosure  (\Int
_ -> forall a. Show a => a -> String
show) Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize forall a b. (a -> b) -> a -> b
$ DebugClosureWithSize (GenSrtPayload c) p ConstrDesc s c
d) forall a. [a] -> [a] -> [a]
++  String
" <" forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"nl" SourceInformation -> String
tdisplay Maybe SourceInformation
l forall a. [a] -> [a] -> [a]
++ String
">"
            where
              tdisplay :: SourceInformation -> String
tdisplay SourceInformation
sl = SourceInformation -> String
infoName SourceInformation
sl forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoType SourceInformation
sl forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoModule SourceInformation
sl forall a. [a] -> [a] -> [a]
++ 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 (forall a. Show a => a -> String
show a
k forall a. [a] -> [a] -> [a]
++ String
"-------------------------------------")
            forall a. Show a => a -> IO ()
print a
l
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
      forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ 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