{-# LANGUAGE ViewPatterns #-}
-- | Functions for computing retainers
module GHC.Debug.Retainers(findRetainersOf, findRetainersOfConstructor, findRetainersOfConstructorExact, 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) = (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]
roots String
con_name =
  Maybe Int
-> [ClosurePtr]
-> (ClosurePtr -> SizedClosure -> DebugM Bool)
-> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit [ClosurePtr]
roots forall {p} {pap} {s} {b}.
p -> DebugClosureWithSize pap ConstrDescCont s b -> DebugM Bool
go
  where
    go :: p -> DebugClosureWithSize pap ConstrDescCont s b -> DebugM Bool
go p
cp DebugClosureWithSize pap ConstrDescCont s b
sc =
      case forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize DebugClosureWithSize 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 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]
roots String
clos_name =
  Maybe Int
-> [ClosurePtr]
-> (ClosurePtr -> SizedClosure -> DebugM Bool)
-> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit [ClosurePtr]
roots forall {p} {pap} {string} {s} {b}.
p -> DebugClosureWithSize pap string s b -> DebugM Bool
go
  where
    go :: p -> DebugClosureWithSize pap string s b -> DebugM Bool
go p
cp DebugClosureWithSize pap string s b
sc = do
      Maybe SourceInformation
loc <- ConstrDescCont -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> ConstrDescCont
tableId (forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize DebugClosureWithSize 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
loc -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceInformation -> String
infoLabel SourceInformation
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 ())
              , stackTrace :: GenStackFrames 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 pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure 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 [(SizedClosureC, Maybe SourceInformation)]
addLocationToStack :: [ClosurePtr] -> DebugM [(SizedClosureC, Maybe SourceInformation)]
addLocationToStack [ClosurePtr]
r = do
  [SizedClosure]
cs <- [ClosurePtr] -> DebugM [SizedClosure]
dereferenceClosures [ClosurePtr]
r
  [SizedClosureC]
cs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Applicative f => a -> f a
pure) [SizedClosure]
cs
  [Maybe SourceInformation]
locs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {pap} {string} {s} {b}.
DebugClosureWithSize pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc [SizedClosureC]
cs'
  return $ (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 (forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (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) =
            (forall c p s.
String
-> (Int -> c -> String)
-> Int
-> DebugClosure p ConstrDesc s c
-> String
ppClosure String
""  (\Int
_ -> forall a. Show a => a -> String
show) Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize forall a b. (a -> b) -> a -> b
$ DebugClosureWithSize 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
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 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 (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 p ConstrDesc s c, Maybe SourceInformation)
-> String
disp) t (DebugClosureWithSize 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 p ConstrDesc s c, Maybe SourceInformation))
-> IO (t ())
do_one [Int
0 :: Int ..] [(String, [(SizedClosureC, Maybe SourceInformation)])]
rs