module GHC.Debug.Snapshot (
snapshot
, makeSnapshot
, snapshotRun
, traceFrom ) where
import GHC.Debug.Trace
import GHC.Debug.ParTrace
import GHC.Debug.Client.Monad
import GHC.Debug.Client
import Control.Monad.Identity
import Control.Monad.Trans
snapshot :: FilePath -> DebugM ()
snapshot :: FilePath -> DebugM ()
snapshot FilePath
fp = do
DebugM [RawBlock]
precacheBlocks
[ClosurePtr]
rs <- DebugM [ClosurePtr]
gcRoots
[ClosurePtr]
_so <- DebugM [ClosurePtr]
savedObjects
[ClosurePtr] -> DebugM ()
tracePar [ClosurePtr]
rs
FilePath -> DebugM ()
forall (m :: * -> *). DebugMonad m => FilePath -> m ()
saveCache FilePath
fp
traceFrom :: [ClosurePtr] -> DebugM ()
traceFrom :: [ClosurePtr] -> DebugM ()
traceFrom [ClosurePtr]
cps = IdentityT DebugM () -> DebugM ()
forall {k} (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT (TraceFunctions IdentityT -> [ClosurePtr] -> IdentityT DebugM ()
forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m -> [ClosurePtr] -> m DebugM ()
traceFromM TraceFunctions IdentityT
funcs [ClosurePtr]
cps)
where
nop :: b -> IdentityT DebugM ()
nop = IdentityT DebugM () -> b -> IdentityT DebugM ()
forall a b. a -> b -> a
const (() -> IdentityT DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
funcs :: TraceFunctions IdentityT
funcs = (GenPapPayload ClosurePtr -> IdentityT DebugM ())
-> (GenStackFrames ClosurePtr -> IdentityT DebugM ())
-> (ClosurePtr
-> SizedClosure -> IdentityT DebugM () -> IdentityT DebugM ())
-> (ClosurePtr -> IdentityT DebugM ())
-> (ConstrDesc -> IdentityT DebugM ())
-> TraceFunctions IdentityT
forall (m :: (* -> *) -> * -> *).
(GenPapPayload ClosurePtr -> m DebugM ())
-> (GenStackFrames ClosurePtr -> m DebugM ())
-> (ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())
-> (ClosurePtr -> m DebugM ())
-> (ConstrDesc -> m DebugM ())
-> TraceFunctions m
TraceFunctions GenPapPayload ClosurePtr -> IdentityT DebugM ()
forall {b}. b -> IdentityT DebugM ()
nop GenStackFrames ClosurePtr -> IdentityT DebugM ()
forall {b}. b -> IdentityT DebugM ()
nop ClosurePtr
-> SizedClosure -> IdentityT DebugM () -> IdentityT DebugM ()
clos (IdentityT DebugM () -> ClosurePtr -> IdentityT DebugM ()
forall a b. a -> b -> a
const (() -> IdentityT DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())) ConstrDesc -> IdentityT DebugM ()
forall {b}. b -> IdentityT DebugM ()
nop
clos :: ClosurePtr -> SizedClosure -> (IdentityT DebugM) ()
-> (IdentityT DebugM) ()
clos :: ClosurePtr
-> SizedClosure -> IdentityT DebugM () -> IdentityT DebugM ()
clos ClosurePtr
_cp SizedClosure
sc IdentityT DebugM ()
k = do
let itb :: StgInfoTableWithPtr
itb = DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
-> StgInfoTableWithPtr
forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (SizedClosure
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize SizedClosure
sc)
Maybe SourceInformation
_traced <- DebugM (Maybe SourceInformation)
-> IdentityT DebugM (Maybe SourceInformation)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM (Maybe SourceInformation)
-> IdentityT DebugM (Maybe SourceInformation))
-> DebugM (Maybe SourceInformation)
-> IdentityT DebugM (Maybe SourceInformation)
forall a b. (a -> b) -> a -> b
$ ConstrDescCont -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> ConstrDescCont
tableId StgInfoTableWithPtr
itb)
IdentityT DebugM ()
k
makeSnapshot :: Debuggee -> FilePath -> IO ()
makeSnapshot :: Debuggee -> FilePath -> IO ()
makeSnapshot Debuggee
e FilePath
fp = DebugM () -> (() -> IO ()) -> Debuggee -> IO ()
forall a r. DebugM a -> (a -> IO r) -> Debuggee -> IO r
runAnalysis (FilePath -> DebugM ()
snapshot FilePath
fp) (IO () -> () -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())) Debuggee
e