{-# 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
raw_bk forall a. Integral a => a -> a -> a
`div` Int
8
      offset :: Word64
offset = ClosurePtr -> Word64
getBlockOffset ClosurePtr
cp forall a. Integral a => a -> a -> a
`div` Word64
8
  in (Int
bk, 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 <- 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 forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
bk IntMap (IOBitArray Word16)
v of
    Maybe (IOBitArray Word16)
Nothing -> do
      IOBitArray Word16
na <- forall i. Ix i => (i, i) -> Bool -> IO (IOBitArray i)
newArray (Word16
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
blockMask forall a. Integral a => a -> a -> a
`div` Word64
8)) Bool
False
      forall i. Ix i => IOBitArray i -> i -> Bool -> IO ()
writeArray IOBitArray Word16
na Word16
offset Bool
True
      forall a. IORef a -> a -> IO ()
writeIORef IORef TraceState
mref (VisitedSet -> Int -> TraceState
TraceState (IntMap (IOBitArray Word16) -> VisitedSet
VisitedSet (forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
bk IOBitArray Word16
na IntMap (IOBitArray Word16)
v)) (Int
num_visited forall a. Num a => a -> a -> a
+ Int
1))
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
num_visited forall a. Integral a => a -> a -> a
`mod` Int
10_000 forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Traced: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
num_visited)
      return Bool
False
    Just IOBitArray Word16
bm -> do
      Bool
res <- forall i. Ix i => IOBitArray i -> i -> IO Bool
readArray IOBitArray Word16
bm Word16
offset
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
res (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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (forall a. a -> IO (IORef a)
newIORef (VisitedSet -> Int -> TraceState
TraceState (IntMap (IOBitArray Word16) -> VisitedSet
VisitedSet forall a. IntMap a
IM.empty) Int
1)))
  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (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 <- forall r (m :: * -> *). MonadReader r m => m r
ask
      Bool
b <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> ClosurePtr -> m DebugM ()
visitedVal TraceFunctions m
k ClosurePtr
cp
        else do
        SizedClosure
sc <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
cp
        forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \IORef TraceState
st -> forall (m :: (* -> *) -> * -> *).
TraceFunctions m
-> ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()
closTrace TraceFunctions m
k ClosurePtr
cp SizedClosure
sc
         (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 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' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ StackCont -> DebugM (GenStackFrames ClosurePtr)
dereferenceStack StackCont
st
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> GenStackFrames ClosurePtr -> m DebugM ()
stackTrace TraceFunctions m
k GenStackFrames ClosurePtr
st'
      () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc ConstrDescCont
d
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ PayloadCont -> DebugM (GenPapPayload ClosurePtr)
dereferencePapPayload PayloadCont
p
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> GenPapPayload ClosurePtr -> m DebugM ()
papTrace TraceFunctions m
k GenPapPayload ClosurePtr
p'
      () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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'