-- | Functions for creating and running snapshots.
module GHC.Debug.Snapshot ( -- * Generating snapshots
                            snapshot
                          , makeSnapshot
                          -- * Using a snapshot
                          , snapshotRun
                          -- * Low level
                          , 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

-- | Make a snapshot of the current heap and save it to the given file.
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

-- | Traverse the tree from GC roots, to populate the caches
-- with everything necessary.
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

-- | Pause the process and create a snapshot of
-- the heap. The snapshot can then be loaded with
-- 'snapshotRun' in order to perform offline analysis.
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