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

import Prelude hiding (filter)
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
import Data.Word

addOne :: a -> (Maybe Int, [a]) -> (Maybe Int, [a])
addOne :: forall a. a -> (Maybe Int, [a]) -> (Maybe Int, [a])
addOne a
_ (Just Int
0, [a]
cp) = (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0, [a]
cp)
addOne a
cp (Maybe Int
n, [a]
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, a
cp a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
cps)

data EraRange
  = EraRange { EraRange -> Word64
startEra :: Word64, EraRange -> Word64
endEra :: Word64} -- inclusive
  deriving (EraRange -> EraRange -> Bool
(EraRange -> EraRange -> Bool)
-> (EraRange -> EraRange -> Bool) -> Eq EraRange
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EraRange -> EraRange -> Bool
== :: EraRange -> EraRange -> Bool
$c/= :: EraRange -> EraRange -> Bool
/= :: EraRange -> EraRange -> Bool
Eq, Eq EraRange
Eq EraRange =>
(EraRange -> EraRange -> Ordering)
-> (EraRange -> EraRange -> Bool)
-> (EraRange -> EraRange -> Bool)
-> (EraRange -> EraRange -> Bool)
-> (EraRange -> EraRange -> Bool)
-> (EraRange -> EraRange -> EraRange)
-> (EraRange -> EraRange -> EraRange)
-> Ord EraRange
EraRange -> EraRange -> Bool
EraRange -> EraRange -> Ordering
EraRange -> EraRange -> EraRange
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: EraRange -> EraRange -> Ordering
compare :: EraRange -> EraRange -> Ordering
$c< :: EraRange -> EraRange -> Bool
< :: EraRange -> EraRange -> Bool
$c<= :: EraRange -> EraRange -> Bool
<= :: EraRange -> EraRange -> Bool
$c> :: EraRange -> EraRange -> Bool
> :: EraRange -> EraRange -> Bool
$c>= :: EraRange -> EraRange -> Bool
>= :: EraRange -> EraRange -> Bool
$cmax :: EraRange -> EraRange -> EraRange
max :: EraRange -> EraRange -> EraRange
$cmin :: EraRange -> EraRange -> EraRange
min :: EraRange -> EraRange -> EraRange
Ord, Int -> EraRange -> ShowS
[EraRange] -> ShowS
EraRange -> String
(Int -> EraRange -> ShowS)
-> (EraRange -> String) -> ([EraRange] -> ShowS) -> Show EraRange
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EraRange -> ShowS
showsPrec :: Int -> EraRange -> ShowS
$cshow :: EraRange -> String
show :: EraRange -> String
$cshowList :: [EraRange] -> ShowS
showList :: [EraRange] -> ShowS
Show)

inEraRange :: Word64 -> Maybe EraRange -> Bool
inEraRange :: Word64 -> Maybe EraRange -> Bool
inEraRange Word64
_ Maybe EraRange
Nothing = Bool
True
inEraRange Word64
n (Just (EraRange Word64
s Word64
e)) = Word64
s Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
n Bool -> Bool -> Bool
&& Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
e

profHeaderReferencesCCS :: Maybe ProfHeaderWithPtr -> Set.Set CCSPtr -> Bool
profHeaderReferencesCCS :: Maybe ProfHeaderWithPtr -> Set CCSPtr -> Bool
profHeaderReferencesCCS Maybe ProfHeaderWithPtr
Nothing Set CCSPtr
_ = Bool
False
profHeaderReferencesCCS (Just ProfHeaderWithPtr
profHeader) Set CCSPtr
f = ProfHeaderWithPtr -> CCSPtr
forall a. ProfHeader a -> a
ccs ProfHeaderWithPtr
profHeader CCSPtr -> Set CCSPtr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set CCSPtr
f

profHeaderInEraRange :: Maybe (ProfHeader a) -> Maybe EraRange -> Bool
profHeaderInEraRange :: forall a. Maybe (ProfHeader a) -> Maybe EraRange -> Bool
profHeaderInEraRange Maybe (ProfHeader a)
Nothing Maybe EraRange
_ = Bool
True
profHeaderInEraRange (Just ProfHeader a
ph) Maybe EraRange
eras
  = case ProfHeader a -> ProfHeaderWord
forall a. ProfHeader a -> ProfHeaderWord
hp ProfHeader a
ph of
      EraWord Word64
w -> Word64
w Word64 -> Maybe EraRange -> Bool
`inEraRange` Maybe EraRange
eras
      ProfHeaderWord
_ -> Bool
True -- Don't filter if no era profiling

data ClosureFilter
 = ConstructorDescFilter (ConstrDesc -> Bool)
 | InfoFilter (StgInfoTable -> Bool)
 | InfoPtrFilter (InfoTablePtr -> Bool)
 | InfoSourceFilter (SourceInformation -> Bool)
 | SizeFilter (Size -> Bool)
 | ProfHeaderFilter (Maybe ProfHeaderWithPtr -> Bool)
 | AddressFilter (ClosurePtr -> Bool)
 | AndFilter ClosureFilter ClosureFilter
 | OrFilter ClosureFilter ClosureFilter
 | NotFilter ClosureFilter
 | PureFilter Bool

matchesFilter :: ClosureFilter -> ClosurePtr -> SizedClosure -> [ClosurePtr] -> DebugM Bool
matchesFilter :: ClosureFilter
-> ClosurePtr -> SizedClosure -> [ClosurePtr] -> DebugM Bool
matchesFilter ClosureFilter
filter ClosurePtr
ptr SizedClosure
sc [ClosurePtr]
parents = case ClosureFilter
filter of
  ConstructorDescFilter ConstrDesc -> Bool
p -> case SizedClosure
-> DebugClosure
     CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize SizedClosure
sc of
    ConstrClosure StgInfoTableWithPtr
_ Maybe ProfHeaderWithPtr
_ [ClosurePtr]
_ [Word]
_ InfoTablePtr
cd -> do
      ConstrDesc
cd' <- InfoTablePtr -> DebugM ConstrDesc
dereferenceConDesc InfoTablePtr
cd
      return $ ConstrDesc -> Bool
p ConstrDesc
cd'
    DebugClosure
  CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
_ -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  InfoFilter StgInfoTable -> Bool
p -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> DebugM Bool) -> Bool -> DebugM Bool
forall a b. (a -> b) -> a -> b
$ StgInfoTable -> Bool
p (StgInfoTableWithPtr -> StgInfoTable
decodedTable (DebugClosure
  CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
-> StgInfoTableWithPtr
forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
info (SizedClosure
-> DebugClosure
     CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize SizedClosure
sc)))
  InfoPtrFilter InfoTablePtr -> Bool
p -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> DebugM Bool) -> Bool -> DebugM Bool
forall a b. (a -> b) -> a -> b
$ InfoTablePtr -> Bool
p (StgInfoTableWithPtr -> InfoTablePtr
tableId (DebugClosure
  CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
-> StgInfoTableWithPtr
forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
info (SizedClosure
-> DebugClosure
     CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize SizedClosure
sc)))
  InfoSourceFilter SourceInformation -> Bool
p -> do
    Maybe SourceInformation
loc <- InfoTablePtr -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> InfoTablePtr
tableId (DebugClosure
  CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
-> StgInfoTableWithPtr
forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
info (SizedClosure
-> DebugClosure
     CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize SizedClosure
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> DebugM Bool) -> Bool -> DebugM Bool
forall a b. (a -> b) -> a -> b
$ SourceInformation -> Bool
p SourceInformation
cur_loc
  SizeFilter Size -> Bool
p -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> DebugM Bool) -> Bool -> DebugM Bool
forall a b. (a -> b) -> a -> b
$ Size -> Bool
p (SizedClosure -> Size
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b -> Size
dcSize SizedClosure
sc)
  ProfHeaderFilter Maybe ProfHeaderWithPtr -> Bool
p -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> DebugM Bool) -> Bool -> DebugM Bool
forall a b. (a -> b) -> a -> b
$ Maybe ProfHeaderWithPtr -> Bool
p (DebugClosure
  CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
-> Maybe ProfHeaderWithPtr
forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> Maybe (ProfHeader ccs)
profHeader (DebugClosure
   CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
 -> Maybe ProfHeaderWithPtr)
-> DebugClosure
     CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
-> Maybe ProfHeaderWithPtr
forall a b. (a -> b) -> a -> b
$ SizedClosure
-> DebugClosure
     CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize SizedClosure
sc)
  AddressFilter ClosurePtr -> Bool
p -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> DebugM Bool) -> Bool -> DebugM Bool
forall a b. (a -> b) -> a -> b
$ ClosurePtr -> Bool
p ClosurePtr
ptr
  AndFilter ClosureFilter
f1 ClosureFilter
f2 -> do
    Bool
r1 <- ClosureFilter
-> ClosurePtr -> SizedClosure -> [ClosurePtr] -> DebugM Bool
matchesFilter ClosureFilter
f1 ClosurePtr
ptr SizedClosure
sc [ClosurePtr]
parents
    case Bool
r1 of
      Bool
False -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Bool
True -> ClosureFilter
-> ClosurePtr -> SizedClosure -> [ClosurePtr] -> DebugM Bool
matchesFilter ClosureFilter
f2 ClosurePtr
ptr SizedClosure
sc [ClosurePtr]
parents
  OrFilter ClosureFilter
f1 ClosureFilter
f2 -> do
    Bool
r1 <- ClosureFilter
-> ClosurePtr -> SizedClosure -> [ClosurePtr] -> DebugM Bool
matchesFilter ClosureFilter
f1 ClosurePtr
ptr SizedClosure
sc [ClosurePtr]
parents
    case Bool
r1 of
      Bool
True -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      Bool
False -> ClosureFilter
-> ClosurePtr -> SizedClosure -> [ClosurePtr] -> DebugM Bool
matchesFilter ClosureFilter
f2 ClosurePtr
ptr SizedClosure
sc [ClosurePtr]
parents
  NotFilter ClosureFilter
f1  -> do
    Bool
r1 <- ClosureFilter
-> ClosurePtr -> SizedClosure -> [ClosurePtr] -> DebugM Bool
matchesFilter ClosureFilter
f1 ClosurePtr
ptr SizedClosure
sc [ClosurePtr]
parents
    pure (Bool -> Bool
not Bool
r1)
  PureFilter Bool
b -> Bool -> DebugM Bool
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b

findRetainersOf :: Maybe Int
                -> [ClosurePtr]
                -> [ClosurePtr]
                -> DebugM [[ClosurePtr]]
findRetainersOf :: Maybe Int -> [ClosurePtr] -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainersOf Maybe Int
limit [ClosurePtr]
cps [ClosurePtr]
bads =
  Maybe Int -> ClosureFilter -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit ((ClosurePtr -> Bool) -> ClosureFilter
AddressFilter (ClosurePtr -> Set ClosurePtr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ClosurePtr
bad_set)) [ClosurePtr]
cps
  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 -> ClosureFilter -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit ((ConstrDesc -> Bool) -> ClosureFilter
ConstructorDescFilter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
con_name) (String -> Bool) -> (ConstrDesc -> String) -> ConstrDesc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstrDesc -> String
name)) [ClosurePtr]
rroots

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 -> ClosureFilter -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit ((SourceInformation -> Bool) -> ClosureFilter
InfoSourceFilter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
clos_name) (String -> Bool)
-> (SourceInformation -> String) -> SourceInformation -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceInformation -> String
infoName)) [ClosurePtr]
rroots

findRetainersOfEra
  :: Maybe Int
  -> EraRange
  -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainersOfEra :: Maybe Int -> EraRange -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainersOfEra Maybe Int
limit EraRange
eras [ClosurePtr]
rroots =
  Maybe Int -> ClosureFilter -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit ClosureFilter
filter [ClosurePtr]
rroots
  where
    filter :: ClosureFilter
filter = (Maybe ProfHeaderWithPtr -> Bool) -> ClosureFilter
ProfHeaderFilter (Maybe ProfHeaderWithPtr -> Maybe EraRange -> Bool
forall a. Maybe (ProfHeader a) -> Maybe EraRange -> Bool
`profHeaderInEraRange` (EraRange -> Maybe EraRange
forall a. a -> Maybe a
Just EraRange
eras))

findRetainersOfArrWords
  :: Maybe Int
  -> [ClosurePtr] -> Size -> DebugM [[ClosurePtr]]
findRetainersOfArrWords :: Maybe Int -> [ClosurePtr] -> Size -> DebugM [[ClosurePtr]]
findRetainersOfArrWords Maybe Int
limit [ClosurePtr]
rroots Size
lim =
  Maybe Int -> ClosureFilter -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit ClosureFilter
filter [ClosurePtr]
rroots
  where
    -- TODO : this is the size of the entire closure, not the size of the ArrWords
    filter :: ClosureFilter
filter = ClosureFilter -> ClosureFilter -> ClosureFilter
AndFilter ((StgInfoTable -> Bool) -> ClosureFilter
InfoFilter ((ClosureType -> ClosureType -> Bool
forall a. Eq a => a -> a -> Bool
== ClosureType
ARR_WORDS) (ClosureType -> Bool)
-> (StgInfoTable -> ClosureType) -> StgInfoTable -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgInfoTable -> ClosureType
tipe))
                       ((Size -> Bool) -> ClosureFilter
SizeFilter (Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
>= Size
lim))

findRetainersOfInfoTable
  :: Maybe Int
  -> [ClosurePtr] -> InfoTablePtr -> DebugM [[ClosurePtr]]
findRetainersOfInfoTable :: Maybe Int -> [ClosurePtr] -> InfoTablePtr -> DebugM [[ClosurePtr]]
findRetainersOfInfoTable Maybe Int
limit [ClosurePtr]
rroots InfoTablePtr
info_ptr =
  Maybe Int -> ClosureFilter -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit ((InfoTablePtr -> Bool) -> ClosureFilter
InfoPtrFilter (InfoTablePtr -> InfoTablePtr -> Bool
forall a. Eq a => a -> a -> Bool
== InfoTablePtr
info_ptr)) [ClosurePtr]
rroots

-- | 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
  -> ClosureFilter
  -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainers :: Maybe Int -> ClosureFilter -> [ClosurePtr] -> DebugM [[ClosurePtr]]
findRetainers Maybe Int
limit ClosureFilter
filter [ClosurePtr]
rroots = (\(()
_, (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 = (ClosurePtr
 -> SizedClosure
 -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
 -> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ())
-> TraceFunctions
     (RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]))
forall (m :: (* -> *) -> * -> *).
C m =>
(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())
-> TraceFunctions m
justClosures ClosurePtr
-> SizedClosure
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
-> RWST [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM ()
closAccum
    -- 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
     CCSPtr InfoTablePtr PayloadCont InfoTablePtr StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs 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
      [ClosurePtr]
ctx <- RWST
  [ClosurePtr] () (Maybe Int, [[ClosurePtr]]) DebugM [ClosurePtr]
forall r (m :: * -> *). MonadReader r m => m r
ask
      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
$ ClosureFilter
-> ClosurePtr -> SizedClosure -> [ClosurePtr] -> DebugM Bool
matchesFilter ClosureFilter
filter ClosurePtr
cp SizedClosure
sc [ClosurePtr]
ctx
      if Bool
b
      then do
        ((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]])
forall a. a -> (Maybe Int, [a]) -> (Maybe Int, [a])
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
      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 {ccs} {srt} {pap} {string} {s} {b}.
DebugClosureWithSize ccs 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 ccs srt pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc DebugClosureWithSize ccs srt pap string s b
c = InfoTablePtr -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> InfoTablePtr
tableId (DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
info (DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize DebugClosureWithSize ccs 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 {ccs} {srt} {pap} {string} {s} {b}.
DebugClosureWithSize ccs 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 ccs srt pap string s b
-> DebugM (Maybe SourceInformation)
getSourceLoc DebugClosureWithSize ccs srt pap string s b
c = InfoTablePtr -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> InfoTablePtr
tableId (DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
info (DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize DebugClosureWithSize ccs 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 ccs (GenSrtPayload c) p ConstrDesc s c,
 Maybe SourceInformation)
-> String
disp (DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
d, Maybe SourceInformation
l) =
            ((Int -> c -> String)
-> Int
-> DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
-> String
forall c ccs p s.
(Int -> c -> String)
-> Int
-> DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
-> String
ppClosure  (\Int
_ -> c -> String
forall a. Show a => a -> String
show) Int
0 (DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c -> String)
-> (DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
    -> DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c)
-> DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
-> DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize (DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
 -> String)
-> DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
-> String
forall a b. (a -> b) -> a -> b
$ DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
d) String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
" <" String -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
            where
              tdisplay :: SourceInformation -> String
tdisplay SourceInformation
sl = SourceInformation -> String
infoName SourceInformation
sl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoType SourceInformation
sl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoModule SourceInformation
sl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoPosition SourceInformation
sl
          do_one :: a
-> (a,
    t (DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c,
       Maybe SourceInformation))
-> IO (t ())
do_one a
k (a
l, t (DebugClosureWithSize ccs (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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-------------------------------------")
            a -> IO ()
forall a. Show a => a -> IO ()
print a
l
            ((DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c,
  Maybe SourceInformation)
 -> IO ())
-> t (DebugClosureWithSize ccs (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 ccs (GenSrtPayload c) p ConstrDesc s c,
     Maybe SourceInformation)
    -> String)
-> (DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c,
    Maybe SourceInformation)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c,
 Maybe SourceInformation)
-> String
forall {c} {ccs} {p} {s}.
Show c =>
(DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c,
 Maybe SourceInformation)
-> String
disp) t (DebugClosureWithSize ccs (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} {ccs} {p} {s}.
(Traversable t, Show a, Show a, Show c) =>
a
-> (a,
    t (DebugClosureWithSize ccs (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 ccs (GenSrtPayload c) p ConstrDesc s c,
 Maybe SourceInformation)
-> String
disp (a
p, DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
d, Maybe SourceInformation
l) =
            a -> String
forall a. Show a => a -> String
show a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((Int -> c -> String)
-> Int
-> DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
-> String
forall c ccs p s.
(Int -> c -> String)
-> Int
-> DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
-> String
ppClosure  (\Int
_ -> c -> String
forall a. Show a => a -> String
show) Int
0 (DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c -> String)
-> (DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
    -> DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c)
-> DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
-> DebugClosure ccs (GenSrtPayload c) p ConstrDesc s c
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize (DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
 -> String)
-> DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
-> String
forall a b. (a -> b) -> a -> b
$ DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c
d) String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
" <" String -> ShowS
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"
            where
              tdisplay :: SourceInformation -> String
tdisplay SourceInformation
sl = SourceInformation -> String
infoName SourceInformation
sl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoType SourceInformation
sl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoModule SourceInformation
sl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SourceInformation -> String
infoPosition SourceInformation
sl
          do_one :: a
-> (a,
    t (a, DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c,
       Maybe SourceInformation))
-> IO (t ())
do_one a
k (a
l, t (a, DebugClosureWithSize ccs (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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-------------------------------------")
            a -> IO ()
forall a. Show a => a -> IO ()
print a
l
            ((a, DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c,
  Maybe SourceInformation)
 -> IO ())
-> t (a,
      DebugClosureWithSize ccs (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 ccs (GenSrtPayload c) p ConstrDesc s c,
     Maybe SourceInformation)
    -> String)
-> (a, DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c,
    Maybe SourceInformation)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c,
 Maybe SourceInformation)
-> String
forall {a} {c} {ccs} {p} {s}.
(Show a, Show c) =>
(a, DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c,
 Maybe SourceInformation)
-> String
disp) t (a, DebugClosureWithSize ccs (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} {ccs} {p} {s}.
(Traversable t, Show a, Show a, Show a, Show c) =>
a
-> (a,
    t (a, DebugClosureWithSize ccs (GenSrtPayload c) p ConstrDesc s c,
       Maybe SourceInformation))
-> IO (t ())
do_one [Int
0 :: Int ..] [(String, [(ClosurePtr, SizedClosureP, Maybe SourceInformation)])]
rs