{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE BangPatterns #-}
-- | Functions to support the constant space traversal of a heap.
module GHC.Debug.Trace ( traceFromM, TraceFunctions(..) ) where

import           GHC.Debug.Types
import GHC.Debug.Client.Monad
import           GHC.Debug.Client.Query

import qualified Data.IntMap as IM
import Data.Array.BitArray.IO
import Control.Monad.Reader
import Data.IORef
import Data.Word
import System.IO

newtype VisitedSet = VisitedSet (IM.IntMap (IOBitArray Word16))

data TraceState = TraceState { TraceState -> VisitedSet
visited :: !VisitedSet, TraceState -> Int
n :: !Int }


getKeyPair :: ClosurePtr -> (Int, Word16)
getKeyPair :: ClosurePtr -> (Int, Word16)
getKeyPair ClosurePtr
cp =
  let BlockPtr Word64
raw_bk = ClosurePtr -> BlockPtr
applyBlockMask ClosurePtr
cp
      bk :: Int
bk = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
raw_bk Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
      offset :: Word64
offset = ClosurePtr -> Word64
getBlockOffset ClosurePtr
cp Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
8
  in (Int
bk, Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
offset)

checkVisit :: ClosurePtr -> IORef TraceState -> IO Bool
checkVisit :: ClosurePtr -> IORef TraceState -> IO Bool
checkVisit ClosurePtr
cp IORef TraceState
mref = do
  TraceState
st <- IORef TraceState -> IO TraceState
forall a. IORef a -> IO a
readIORef IORef TraceState
mref
  let VisitedSet IntMap (IOBitArray Word16)
v = TraceState -> VisitedSet
visited TraceState
st
      num_visited :: Int
num_visited = TraceState -> Int
n TraceState
st
      (Int
bk, Word16
offset) = ClosurePtr -> (Int, Word16)
getKeyPair ClosurePtr
cp
  case Int -> IntMap (IOBitArray Word16) -> Maybe (IOBitArray Word16)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
bk IntMap (IOBitArray Word16)
v of
    Maybe (IOBitArray Word16)
Nothing -> do
      IOBitArray Word16
na <- (Word16, Word16) -> Bool -> IO (IOBitArray Word16)
forall i. Ix i => (i, i) -> Bool -> IO (IOBitArray i)
newArray (Word16
0, Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
blockMask Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
8)) Bool
False
      IOBitArray Word16 -> Word16 -> Bool -> IO ()
forall i. Ix i => IOBitArray i -> i -> Bool -> IO ()
writeArray IOBitArray Word16
na Word16
offset Bool
True
      IORef TraceState -> TraceState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef TraceState
mref (VisitedSet -> Int -> TraceState
TraceState (IntMap (IOBitArray Word16) -> VisitedSet
VisitedSet (Int
-> IOBitArray Word16
-> IntMap (IOBitArray Word16)
-> IntMap (IOBitArray Word16)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
bk IOBitArray Word16
na IntMap (IOBitArray Word16)
v)) (Int
num_visited Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
num_visited Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
10_000 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Traced: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
num_visited)
      return Bool
False
    Just IOBitArray Word16
bm -> do
      Bool
res <- IOBitArray Word16 -> Word16 -> IO Bool
forall i. Ix i => IOBitArray i -> i -> IO Bool
readArray IOBitArray Word16
bm Word16
offset
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
res (IOBitArray Word16 -> Word16 -> Bool -> IO ()
forall i. Ix i => IOBitArray i -> i -> Bool -> IO ()
writeArray IOBitArray Word16
bm Word16
offset Bool
True)
      return Bool
res



data TraceFunctions m =
      TraceFunctions { forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> GenPapPayload ClosurePtr -> m DebugM ()
papTrace :: !(GenPapPayload ClosurePtr -> m DebugM ())
      , forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> GenStackFrames ClosurePtr -> m DebugM ()
stackTrace :: !(GenStackFrames ClosurePtr -> m DebugM ())
      , forall (m :: (* -> *) -> * -> *).
TraceFunctions m
-> ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()
closTrace :: !(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())
      , forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> ClosurePtr -> m DebugM ()
visitedVal :: !(ClosurePtr -> (m DebugM) ())
      , forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> ConstrDesc -> m DebugM ()
conDescTrace :: !(ConstrDesc -> m DebugM ())
      }




type C m = (MonadTrans m, Monad (m DebugM))

-- | A generic heap traversal function which will use a small amount of
-- memory linear in the heap size. Using this function with appropiate
-- accumulation functions you should be able to traverse quite big heaps in
-- not a huge amount of memory.
traceFromM :: C m => TraceFunctions m-> [ClosurePtr] -> m DebugM ()
traceFromM :: forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m -> [ClosurePtr] -> m DebugM ()
traceFromM TraceFunctions m
k [ClosurePtr]
cps = do
  IORef TraceState
st <- DebugM (IORef TraceState) -> m DebugM (IORef TraceState)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (IORef TraceState) -> DebugM (IORef TraceState)
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (TraceState -> IO (IORef TraceState)
forall a. a -> IO (IORef a)
newIORef (VisitedSet -> Int -> TraceState
TraceState (IntMap (IOBitArray Word16) -> VisitedSet
VisitedSet IntMap (IOBitArray Word16)
forall a. IntMap a
IM.empty) Int
1)))
  ReaderT (IORef TraceState) (m DebugM) ()
-> IORef TraceState -> m DebugM ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ((ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ())
-> [ClosurePtr] -> ReaderT (IORef TraceState) (m DebugM) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TraceFunctions m
-> ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m
-> ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
traceClosureFromM TraceFunctions m
k) [ClosurePtr]
cps) IORef TraceState
st
{-# INLINE traceFromM #-}
{-# INLINE traceClosureFromM #-}

traceClosureFromM :: C m
                  => TraceFunctions m
                  -> ClosurePtr
                  -> ReaderT (IORef TraceState) (m DebugM) ()
traceClosureFromM :: forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m
-> ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
traceClosureFromM !TraceFunctions m
k = ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
go
  where
    go :: ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
go ClosurePtr
cp = do
      IORef TraceState
mref <- ReaderT (IORef TraceState) (m DebugM) (IORef TraceState)
forall r (m :: * -> *). MonadReader r m => m r
ask
      Bool
b <- m DebugM Bool -> ReaderT (IORef TraceState) (m DebugM) Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM Bool -> ReaderT (IORef TraceState) (m DebugM) Bool)
-> m DebugM Bool -> ReaderT (IORef TraceState) (m DebugM) Bool
forall a b. (a -> b) -> a -> b
$ DebugM Bool -> m DebugM Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM Bool -> m DebugM Bool) -> DebugM Bool -> m DebugM Bool
forall a b. (a -> b) -> a -> b
$ IO Bool -> DebugM Bool
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (ClosurePtr -> IORef TraceState -> IO Bool
checkVisit ClosurePtr
cp IORef TraceState
mref)
      if Bool
b
        then m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ())
-> m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ TraceFunctions m -> ClosurePtr -> m DebugM ()
forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> ClosurePtr -> m DebugM ()
visitedVal TraceFunctions m
k ClosurePtr
cp
        else do
        SizedClosure
sc <- m DebugM SizedClosure
-> ReaderT (IORef TraceState) (m DebugM) SizedClosure
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM SizedClosure
 -> ReaderT (IORef TraceState) (m DebugM) SizedClosure)
-> m DebugM SizedClosure
-> ReaderT (IORef TraceState) (m DebugM) SizedClosure
forall a b. (a -> b) -> a -> b
$ DebugM SizedClosure -> m DebugM SizedClosure
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM SizedClosure -> m DebugM SizedClosure)
-> DebugM SizedClosure -> m DebugM SizedClosure
forall a b. (a -> b) -> a -> b
$ ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
cp
        (IORef TraceState -> m DebugM ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((IORef TraceState -> m DebugM ())
 -> ReaderT (IORef TraceState) (m DebugM) ())
-> (IORef TraceState -> m DebugM ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ \IORef TraceState
st -> TraceFunctions m
-> ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()
forall (m :: (* -> *) -> * -> *).
TraceFunctions m
-> ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()
closTrace TraceFunctions m
k ClosurePtr
cp SizedClosure
sc
         (ReaderT (IORef TraceState) (m DebugM) ()
-> IORef TraceState -> m DebugM ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (() ()
-> ReaderT
     (IORef TraceState)
     (m DebugM)
     (DebugClosureWithExtra Size () () () ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (PayloadCont -> ReaderT (IORef TraceState) (m DebugM) ())
-> (ConstrDescCont -> ReaderT (IORef TraceState) (m DebugM) ())
-> (StackCont -> ReaderT (IORef TraceState) (m DebugM) ())
-> (ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ())
-> SizedClosure
-> ReaderT
     (IORef TraceState)
     (m DebugM)
     (DebugClosureWithExtra Size () () () ())
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 PayloadCont -> ReaderT (IORef TraceState) (m DebugM) ()
gop ConstrDescCont -> ReaderT (IORef TraceState) (m DebugM) ()
forall {t :: (* -> *) -> * -> *}.
(Monad (t (m DebugM)), MonadTrans t) =>
ConstrDescCont -> t (m DebugM) ()
gocd StackCont -> ReaderT (IORef TraceState) (m DebugM) ()
gos ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
go SizedClosure
sc) IORef TraceState
st)


    gos :: StackCont -> ReaderT (IORef TraceState) (m DebugM) ()
gos StackCont
st = do
      GenStackFrames ClosurePtr
st' <- m DebugM (GenStackFrames ClosurePtr)
-> ReaderT
     (IORef TraceState) (m DebugM) (GenStackFrames ClosurePtr)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM (GenStackFrames ClosurePtr)
 -> ReaderT
      (IORef TraceState) (m DebugM) (GenStackFrames ClosurePtr))
-> m DebugM (GenStackFrames ClosurePtr)
-> ReaderT
     (IORef TraceState) (m DebugM) (GenStackFrames ClosurePtr)
forall a b. (a -> b) -> a -> b
$ DebugM (GenStackFrames ClosurePtr)
-> m DebugM (GenStackFrames ClosurePtr)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM (GenStackFrames ClosurePtr)
 -> m DebugM (GenStackFrames ClosurePtr))
-> DebugM (GenStackFrames ClosurePtr)
-> m DebugM (GenStackFrames ClosurePtr)
forall a b. (a -> b) -> a -> b
$ StackCont -> DebugM (GenStackFrames ClosurePtr)
dereferenceStack StackCont
st
      m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ())
-> m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ TraceFunctions m -> GenStackFrames ClosurePtr -> m DebugM ()
forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> GenStackFrames ClosurePtr -> m DebugM ()
stackTrace TraceFunctions m
k GenStackFrames ClosurePtr
st'
      () ()
-> ReaderT (IORef TraceState) (m DebugM) (GenStackFrames ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ())
-> GenStackFrames ClosurePtr
-> ReaderT (IORef TraceState) (m DebugM) (GenStackFrames ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
go GenStackFrames ClosurePtr
st'

    gocd :: ConstrDescCont -> t (m DebugM) ()
gocd ConstrDescCont
d = do
      ConstrDesc
cd <- m DebugM ConstrDesc -> t (m DebugM) ConstrDesc
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM ConstrDesc -> t (m DebugM) ConstrDesc)
-> m DebugM ConstrDesc -> t (m DebugM) ConstrDesc
forall a b. (a -> b) -> a -> b
$ DebugM ConstrDesc -> m DebugM ConstrDesc
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM ConstrDesc -> m DebugM ConstrDesc)
-> DebugM ConstrDesc -> m DebugM ConstrDesc
forall a b. (a -> b) -> a -> b
$ ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc ConstrDescCont
d
      m DebugM () -> t (m DebugM) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM () -> t (m DebugM) ()) -> m DebugM () -> t (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ TraceFunctions m -> ConstrDesc -> m DebugM ()
forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> ConstrDesc -> m DebugM ()
conDescTrace TraceFunctions m
k ConstrDesc
cd

    gop :: PayloadCont -> ReaderT (IORef TraceState) (m DebugM) ()
gop PayloadCont
p = do
      GenPapPayload ClosurePtr
p' <- m DebugM (GenPapPayload ClosurePtr)
-> ReaderT (IORef TraceState) (m DebugM) (GenPapPayload ClosurePtr)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM (GenPapPayload ClosurePtr)
 -> ReaderT
      (IORef TraceState) (m DebugM) (GenPapPayload ClosurePtr))
-> m DebugM (GenPapPayload ClosurePtr)
-> ReaderT (IORef TraceState) (m DebugM) (GenPapPayload ClosurePtr)
forall a b. (a -> b) -> a -> b
$ DebugM (GenPapPayload ClosurePtr)
-> m DebugM (GenPapPayload ClosurePtr)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM (GenPapPayload ClosurePtr)
 -> m DebugM (GenPapPayload ClosurePtr))
-> DebugM (GenPapPayload ClosurePtr)
-> m DebugM (GenPapPayload ClosurePtr)
forall a b. (a -> b) -> a -> b
$ PayloadCont -> DebugM (GenPapPayload ClosurePtr)
dereferencePapPayload PayloadCont
p
      m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ())
-> m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ TraceFunctions m -> GenPapPayload ClosurePtr -> m DebugM ()
forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> GenPapPayload ClosurePtr -> m DebugM ()
papTrace TraceFunctions m
k GenPapPayload ClosurePtr
p'
      () ()
-> ReaderT (IORef TraceState) (m DebugM) (GenPapPayload ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ())
-> GenPapPayload ClosurePtr
-> ReaderT (IORef TraceState) (m DebugM) (GenPapPayload ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
go GenPapPayload ClosurePtr
p'