{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RecordWildCards #-}
{- | Functions for performing whole heap census in the style of the normal
- heap profiling -}
module GHC.Debug.Profile( censusClosureType
                        , census2LevelClosureType
                        , closureCensusBy
                        , CensusByClosureType
                        , writeCensusByClosureType
                        , CensusStats(..)
                        , mkCS
                        , Count(..)
                        , closureToKey ) where

import GHC.Debug.Client.Monad
import GHC.Debug.Client
import GHC.Debug.Trace
import GHC.Debug.ParTrace
import GHC.Debug.Profile.Types

import qualified Data.Map.Strict as Map
import Control.Monad.State
import Data.List (sortBy)
import Data.Ord
import Data.Text (pack, Text, unpack)
import Data.Semigroup
import qualified Data.Text as T
import qualified Data.Map.Monoidal.Strict as MMap
import Data.Bitraversable
import Control.Monad

--import Control.Concurrent
--import Eventlog.Types
--import Eventlog.Data
--import Eventlog.Total
--import Eventlog.HtmlTemplate
--import Eventlog.Args (defaultArgs, Option(..))


type CensusByClosureType = Map.Map Text CensusStats

-- | Perform a heap census in the same style as the -hT profile.
censusClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
censusClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
censusClosureType = (ClosurePtr -> SizedClosure -> DebugM (Maybe (Text, CensusStats)))
-> [ClosurePtr] -> DebugM CensusByClosureType
forall k v.
(Semigroup v, Ord k) =>
(ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
-> [ClosurePtr] -> DebugM (Map k v)
closureCensusBy ClosurePtr -> SizedClosure -> DebugM (Maybe (Text, CensusStats))
go
  where
    go :: ClosurePtr -> SizedClosure
       -> DebugM (Maybe (Text, CensusStats))
    go :: ClosurePtr -> SizedClosure -> DebugM (Maybe (Text, CensusStats))
go ClosurePtr
_ SizedClosure
s = do
      DebugClosureWithExtra
  Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
d <- (SrtCont -> DebugM SrtCont)
-> (PayloadCont -> DebugM PayloadCont)
-> (SrtCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM
     (DebugClosureWithExtra
        Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
forall (f :: * -> *) a b c d e g h i j k.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> DebugClosureWithExtra Size a c e h j
-> f (DebugClosureWithExtra Size b d g i k)
forall (m :: * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d e g
       h i j k.
(Quintraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> m a c e h j
-> f (m b d g i k)
quintraverse SrtCont -> DebugM SrtCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PayloadCont -> DebugM PayloadCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrtCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosurePtr -> DebugM ClosurePtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SizedClosure
s
      let siz :: Size
          siz :: Size
siz = DebugClosureWithExtra
  Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> Size
forall srt pap string s b.
DebugClosureWithSize srt pap string s b -> Size
dcSize DebugClosureWithExtra
  Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
d
          v :: CensusStats
v =  Size -> CensusStats
mkCS Size
siz
      Maybe (Text, CensusStats) -> DebugM (Maybe (Text, CensusStats))
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Maybe (Text, CensusStats) -> DebugM (Maybe (Text, CensusStats)))
-> Maybe (Text, CensusStats) -> DebugM (Maybe (Text, CensusStats))
forall a b. (a -> b) -> a -> b
$ (Text, CensusStats) -> Maybe (Text, CensusStats)
forall a. a -> Maybe a
Just (DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> Text
forall srt a c d. DebugClosure srt a ConstrDesc c d -> Text
closureToKey (DebugClosureWithExtra
  Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithExtra
  Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
d), CensusStats
v)



closureToKey :: DebugClosure srt a ConstrDesc c d -> Text
closureToKey :: forall srt a c d. DebugClosure srt a ConstrDesc c d -> Text
closureToKey DebugClosure srt a ConstrDesc c d
d =
  case DebugClosure srt a ConstrDesc c d
d of
     ConstrClosure { constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
constrDesc = ConstrDesc String
a String
b String
c }
       -> String -> Text
pack String
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
c
     DebugClosure srt a ConstrDesc c d
_ -> String -> Text
pack (ClosureType -> String
forall a. Show a => a -> String
show (StgInfoTable -> ClosureType
tipe (StgInfoTableWithPtr -> StgInfoTable
decodedTable (DebugClosure srt a ConstrDesc c d -> StgInfoTableWithPtr
forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info DebugClosure srt a ConstrDesc c d
d))))


-- | General function for performing a heap census in constant memory
closureCensusBy :: forall k v . (Semigroup v, Ord k)
                => (ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
                -> [ClosurePtr] -> DebugM (Map.Map k v)
closureCensusBy :: forall k v.
(Semigroup v, Ord k) =>
(ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
-> [ClosurePtr] -> DebugM (Map k v)
closureCensusBy ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v))
f [ClosurePtr]
cps = do
  () () -> DebugM [RawBlock] -> DebugM ()
forall a b. a -> DebugM b -> DebugM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ DebugM [RawBlock]
precacheBlocks
  MonoidalMap k v -> Map k v
forall k a. MonoidalMap k a -> Map k a
MMap.getMonoidalMap (MonoidalMap k v -> Map k v)
-> DebugM (MonoidalMap k v) -> DebugM (Map k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TraceFunctionsIO () (MonoidalMap k v)
-> [ClosurePtrWithInfo ()] -> DebugM (MonoidalMap k v)
forall s a.
Monoid s =>
TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s
traceParFromM TraceFunctionsIO () (MonoidalMap k v)
funcs ((ClosurePtr -> ClosurePtrWithInfo ())
-> [ClosurePtr] -> [ClosurePtrWithInfo ()]
forall a b. (a -> b) -> [a] -> [b]
map (() -> ClosurePtr -> ClosurePtrWithInfo ()
forall a. a -> ClosurePtr -> ClosurePtrWithInfo a
ClosurePtrWithInfo ()) [ClosurePtr]
cps)
  where
    funcs :: TraceFunctionsIO () (MonoidalMap k v)
funcs = TraceFunctionsIO {
               papTrace :: GenPapPayload ClosurePtr -> DebugM ()
papTrace = DebugM () -> GenPapPayload ClosurePtr -> DebugM ()
forall a b. a -> b -> a
const (() -> DebugM ()
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , srtTrace :: GenSrtPayload ClosurePtr -> DebugM ()
srtTrace = DebugM () -> GenSrtPayload ClosurePtr -> DebugM ()
forall a b. a -> b -> a
const (() -> DebugM ()
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , stackTrace :: GenStackFrames SrtCont ClosurePtr -> DebugM ()
stackTrace = DebugM () -> GenStackFrames SrtCont ClosurePtr -> DebugM ()
forall a b. a -> b -> a
const (() -> DebugM ()
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , closTrace :: ClosurePtr
-> SizedClosure
-> ()
-> DebugM ((), MonoidalMap k v, DebugM () -> DebugM ())
closTrace = ClosurePtr
-> SizedClosure
-> ()
-> DebugM ((), MonoidalMap k v, DebugM () -> DebugM ())
forall a.
ClosurePtr
-> SizedClosure -> () -> DebugM ((), MonoidalMap k v, a -> a)
closAccum
              , visitedVal :: ClosurePtr -> () -> DebugM (MonoidalMap k v)
visitedVal = (() -> DebugM (MonoidalMap k v))
-> ClosurePtr -> () -> DebugM (MonoidalMap k v)
forall a b. a -> b -> a
const (DebugM (MonoidalMap k v) -> () -> DebugM (MonoidalMap k v)
forall a b. a -> b -> a
const (MonoidalMap k v -> DebugM (MonoidalMap k v)
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return MonoidalMap k v
forall k a. MonoidalMap k a
MMap.empty))
              , conDescTrace :: ConstrDesc -> DebugM ()
conDescTrace = DebugM () -> ConstrDesc -> DebugM ()
forall a b. a -> b -> a
const (() -> DebugM ()
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

            }
    -- Add cos
    closAccum  :: ClosurePtr
               -> SizedClosure
               -> ()
               -> DebugM ((), MMap.MonoidalMap k v, a -> a)
    closAccum :: forall a.
ClosurePtr
-> SizedClosure -> () -> DebugM ((), MonoidalMap k v, a -> a)
closAccum ClosurePtr
cp SizedClosure
s () = do
      Maybe (k, v)
r <- ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v))
f ClosurePtr
cp SizedClosure
s
      ((), MonoidalMap k v, a -> a)
-> DebugM ((), MonoidalMap k v, a -> a)
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return (((), MonoidalMap k v, a -> a)
 -> DebugM ((), MonoidalMap k v, a -> a))
-> (MonoidalMap k v -> ((), MonoidalMap k v, a -> a))
-> MonoidalMap k v
-> DebugM ((), MonoidalMap k v, a -> a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\MonoidalMap k v
s' -> ((), MonoidalMap k v
s', a -> a
forall a. a -> a
id)) (MonoidalMap k v -> DebugM ((), MonoidalMap k v, a -> a))
-> MonoidalMap k v -> DebugM ((), MonoidalMap k v, a -> a)
forall a b. (a -> b) -> a -> b
$ case Maybe (k, v)
r of
        Just (k
k, v
v) -> k -> v -> MonoidalMap k v
forall k a. k -> a -> MonoidalMap k a
MMap.singleton k
k v
v
        Maybe (k, v)
Nothing -> MonoidalMap k v
forall k a. MonoidalMap k a
MMap.empty

-- | Perform a 2-level census where the keys are the type of the closure
-- in addition to the type of ptrs of the closure. This can be used to
-- distinguish between lists of different type for example.
census2LevelClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
census2LevelClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
census2LevelClosureType [ClosurePtr]
cps = ((), CensusByClosureType) -> CensusByClosureType
forall a b. (a, b) -> b
snd (((), CensusByClosureType) -> CensusByClosureType)
-> DebugM ((), CensusByClosureType) -> DebugM CensusByClosureType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT CensusByClosureType DebugM ()
-> CensusByClosureType -> DebugM ((), CensusByClosureType)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (TraceFunctions (StateT CensusByClosureType)
-> [ClosurePtr] -> StateT CensusByClosureType DebugM ()
forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m -> [ClosurePtr] -> m DebugM ()
traceFromM TraceFunctions (StateT CensusByClosureType)
funcs [ClosurePtr]
cps) CensusByClosureType
forall k a. Map k a
Map.empty
  where
    funcs :: TraceFunctions (StateT CensusByClosureType)
funcs = TraceFunctions {
               papTrace :: GenPapPayload ClosurePtr -> StateT CensusByClosureType DebugM ()
papTrace = StateT CensusByClosureType DebugM ()
-> GenPapPayload ClosurePtr -> StateT CensusByClosureType DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusByClosureType DebugM ()
forall a. a -> StateT CensusByClosureType DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , srtTrace :: GenSrtPayload ClosurePtr -> StateT CensusByClosureType DebugM ()
srtTrace = StateT CensusByClosureType DebugM ()
-> GenSrtPayload ClosurePtr -> StateT CensusByClosureType DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusByClosureType DebugM ()
forall a. a -> StateT CensusByClosureType DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , stackTrace :: GenStackFrames SrtCont ClosurePtr
-> StateT CensusByClosureType DebugM ()
stackTrace = StateT CensusByClosureType DebugM ()
-> GenStackFrames SrtCont ClosurePtr
-> StateT CensusByClosureType DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusByClosureType DebugM ()
forall a. a -> StateT CensusByClosureType DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , closTrace :: ClosurePtr
-> SizedClosure
-> StateT CensusByClosureType DebugM ()
-> StateT CensusByClosureType DebugM ()
closTrace = ClosurePtr
-> SizedClosure
-> StateT CensusByClosureType DebugM ()
-> StateT CensusByClosureType DebugM ()
closAccum
              , visitedVal :: ClosurePtr -> StateT CensusByClosureType DebugM ()
visitedVal = StateT CensusByClosureType DebugM ()
-> ClosurePtr -> StateT CensusByClosureType DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusByClosureType DebugM ()
forall a. a -> StateT CensusByClosureType DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              , conDescTrace :: ConstrDesc -> StateT CensusByClosureType DebugM ()
conDescTrace = StateT CensusByClosureType DebugM ()
-> ConstrDesc -> StateT CensusByClosureType DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusByClosureType DebugM ()
forall a. a -> StateT CensusByClosureType DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

            }
    -- Add cos
    closAccum  :: ClosurePtr
               -> SizedClosure
               -> (StateT CensusByClosureType DebugM) ()
               -> (StateT CensusByClosureType DebugM) ()
    closAccum :: ClosurePtr
-> SizedClosure
-> StateT CensusByClosureType DebugM ()
-> StateT CensusByClosureType DebugM ()
closAccum ClosurePtr
_ SizedClosure
s StateT CensusByClosureType DebugM ()
k = do
      DebugClosureWithExtra
  Size
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
s' <- DebugM
  (DebugClosureWithExtra
     Size
     (GenSrtPayload ClosurePtr)
     (GenPapPayload ClosurePtr)
     ConstrDesc
     (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
     ClosurePtr)
-> StateT
     CensusByClosureType
     DebugM
     (DebugClosureWithExtra
        Size
        (GenSrtPayload ClosurePtr)
        (GenPapPayload ClosurePtr)
        ConstrDesc
        (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
        ClosurePtr)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT CensusByClosureType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM
   (DebugClosureWithExtra
      Size
      (GenSrtPayload ClosurePtr)
      (GenPapPayload ClosurePtr)
      ConstrDesc
      (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
      ClosurePtr)
 -> StateT
      CensusByClosureType
      DebugM
      (DebugClosureWithExtra
         Size
         (GenSrtPayload ClosurePtr)
         (GenPapPayload ClosurePtr)
         ConstrDesc
         (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
         ClosurePtr))
-> DebugM
     (DebugClosureWithExtra
        Size
        (GenSrtPayload ClosurePtr)
        (GenPapPayload ClosurePtr)
        ConstrDesc
        (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
        ClosurePtr)
-> StateT
     CensusByClosureType
     DebugM
     (DebugClosureWithExtra
        Size
        (GenSrtPayload ClosurePtr)
        (GenPapPayload ClosurePtr)
        ConstrDesc
        (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
        ClosurePtr)
forall a b. (a -> b) -> a -> b
$ (SrtCont -> DebugM (GenSrtPayload ClosurePtr))
-> (PayloadCont -> DebugM (GenPapPayload ClosurePtr))
-> (SrtCont -> DebugM ConstrDesc)
-> (StackCont
    -> DebugM (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr))
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM
     (DebugClosureWithExtra
        Size
        (GenSrtPayload ClosurePtr)
        (GenPapPayload ClosurePtr)
        ConstrDesc
        (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
        ClosurePtr)
forall (f :: * -> *) a b c d e g h i j k.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> DebugClosureWithExtra Size a c e h j
-> f (DebugClosureWithExtra Size b d g i k)
forall (m :: * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d e g
       h i j k.
(Quintraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> m a c e h j
-> f (m b d g i k)
quintraverse SrtCont -> DebugM (GenSrtPayload ClosurePtr)
dereferenceSRT PayloadCont -> DebugM (GenPapPayload ClosurePtr)
dereferencePapPayload SrtCont -> DebugM ConstrDesc
dereferenceConDesc ((SrtCont -> DebugM (GenSrtPayload ClosurePtr))
-> (ClosurePtr -> DebugM ClosurePtr)
-> GenStackFrames SrtCont ClosurePtr
-> DebugM (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c)
-> (b -> f d) -> GenStackFrames a b -> f (GenStackFrames c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse SrtCont -> DebugM (GenSrtPayload ClosurePtr)
dereferenceSRT ClosurePtr -> DebugM ClosurePtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenStackFrames SrtCont ClosurePtr
 -> DebugM (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr))
-> (StackCont -> DebugM (GenStackFrames SrtCont ClosurePtr))
-> StackCont
-> DebugM (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< StackCont -> DebugM (GenStackFrames SrtCont ClosurePtr)
dereferenceStack) ClosurePtr -> DebugM ClosurePtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SizedClosure
s
      [SizedClosure]
pts <- DebugM [SizedClosure]
-> StateT CensusByClosureType DebugM [SizedClosure]
forall (m :: * -> *) a.
Monad m =>
m a -> StateT CensusByClosureType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM [SizedClosure]
 -> StateT CensusByClosureType DebugM [SizedClosure])
-> DebugM [SizedClosure]
-> StateT CensusByClosureType DebugM [SizedClosure]
forall a b. (a -> b) -> a -> b
$ (ClosurePtr -> DebugM SizedClosure)
-> [ClosurePtr] -> DebugM [SizedClosure]
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 ClosurePtr -> DebugM SizedClosure
dereferenceClosure (DebugClosure
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
-> [ClosurePtr]
forall c a.
DebugClosure
  (GenSrtPayload c)
  (GenPapPayload c)
  a
  (GenStackFrames (GenSrtPayload c) c)
  c
-> [c]
allClosures (DebugClosureWithExtra
  Size
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
-> DebugClosure
     (GenSrtPayload ClosurePtr)
     (GenPapPayload ClosurePtr)
     ConstrDesc
     (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
     ClosurePtr
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithExtra
  Size
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
s'))
      [DebugClosureWithExtra
   Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
pts' <- DebugM
  [DebugClosureWithExtra
     Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
-> StateT
     CensusByClosureType
     DebugM
     [DebugClosureWithExtra
        Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
forall (m :: * -> *) a.
Monad m =>
m a -> StateT CensusByClosureType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM
   [DebugClosureWithExtra
      Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
 -> StateT
      CensusByClosureType
      DebugM
      [DebugClosureWithExtra
         Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr])
-> DebugM
     [DebugClosureWithExtra
        Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
-> StateT
     CensusByClosureType
     DebugM
     [DebugClosureWithExtra
        Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
forall a b. (a -> b) -> a -> b
$ (SizedClosure
 -> DebugM
      (DebugClosureWithExtra
         Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr))
-> [SizedClosure]
-> DebugM
     [DebugClosureWithExtra
        Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
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 ((SrtCont -> DebugM SrtCont)
-> (PayloadCont -> DebugM PayloadCont)
-> (SrtCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM
     (DebugClosureWithExtra
        Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
forall (f :: * -> *) a b c d e g h i j k.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> DebugClosureWithExtra Size a c e h j
-> f (DebugClosureWithExtra Size b d g i k)
forall (m :: * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d e g
       h i j k.
(Quintraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> m a c e h j
-> f (m b d g i k)
quintraverse SrtCont -> DebugM SrtCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PayloadCont -> DebugM PayloadCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrtCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosurePtr -> DebugM ClosurePtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [SizedClosure]
pts


      (CensusByClosureType -> CensusByClosureType)
-> StateT CensusByClosureType DebugM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (DebugClosureWithExtra
  Size
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
-> [DebugClosureWithExtra
      Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
-> CensusByClosureType
-> CensusByClosureType
forall {srt} {pap} {s} {b} {srt} {a} {c} {d}.
DebugClosureWithSize srt pap ConstrDesc s b
-> [DebugClosureWithSize srt a ConstrDesc c d]
-> CensusByClosureType
-> CensusByClosureType
go DebugClosureWithExtra
  Size
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
s' [DebugClosureWithExtra
   Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
pts')
      StateT CensusByClosureType DebugM ()
k

    go :: DebugClosureWithSize srt pap ConstrDesc s b
-> [DebugClosureWithSize srt a ConstrDesc c d]
-> CensusByClosureType
-> CensusByClosureType
go DebugClosureWithSize srt pap ConstrDesc s b
d [DebugClosureWithSize srt a ConstrDesc c d]
args =
      let k :: Text
k = DebugClosure srt pap ConstrDesc s b -> Text
forall srt a c d. DebugClosure srt a ConstrDesc c d -> Text
closureToKey (DebugClosureWithSize srt pap ConstrDesc s b
-> DebugClosure srt pap ConstrDesc s b
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithSize srt pap ConstrDesc s b
d)
          kargs :: [Text]
kargs = (DebugClosureWithSize srt a ConstrDesc c d -> Text)
-> [DebugClosureWithSize srt a ConstrDesc c d] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (DebugClosure srt a ConstrDesc c d -> Text
forall srt a c d. DebugClosure srt a ConstrDesc c d -> Text
closureToKey (DebugClosure srt a ConstrDesc c d -> Text)
-> (DebugClosureWithSize srt a ConstrDesc c d
    -> DebugClosure srt a ConstrDesc c d)
-> DebugClosureWithSize srt a ConstrDesc c d
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosureWithSize srt a ConstrDesc c d
-> DebugClosure srt a ConstrDesc c d
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize) [DebugClosureWithSize srt a ConstrDesc c d]
args
          final_k :: Text
          final_k :: Text
final_k = Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"," [Text]
kargs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
      in (CensusStats -> CensusStats -> CensusStats)
-> Text
-> CensusStats
-> CensusByClosureType
-> CensusByClosureType
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith CensusStats -> CensusStats -> CensusStats
forall a. Semigroup a => a -> a -> a
(<>) Text
final_k (Size -> CensusStats
mkCS (DebugClosureWithSize srt pap ConstrDesc s b -> Size
forall srt pap string s b.
DebugClosureWithSize srt pap string s b -> Size
dcSize DebugClosureWithSize srt pap ConstrDesc s b
d))

{-
-- | Parallel heap census
parCensus :: [RawBlock] -> [ClosurePtr] -> DebugM (Map.Map Text CensusStats)
parCensus bs cs =  do
  MMap.getMonoidalMap <$> (traceParFromM bs funcs (map (ClosurePtrWithInfo ()) cs))

  where
    nop = const (return ())
    funcs = TraceFunctionsIO nop nop clos  (const (const (return mempty))) nop

    clos :: ClosurePtr -> SizedClosure -> ()
              -> DebugM ((), MMap.MonoidalMap Text CensusStats, DebugM () -> DebugM ())
    clos _cp sc () = do
      d <- quintraverse pure dereferenceConDesc pure pure sc
      let s :: Size
          s = dcSize sc
          v =  mkCS s
      return $ ((), MMap.singleton (closureToKey (noSize d)) v, id)
      -}


writeCensusByClosureType :: FilePath -> CensusByClosureType -> IO ()
writeCensusByClosureType :: String -> CensusByClosureType -> IO ()
writeCensusByClosureType String
outpath CensusByClosureType
c = do
  let res :: [(Text, CensusStats)]
res = ((Text, CensusStats) -> (Text, CensusStats) -> Ordering)
-> [(Text, CensusStats)] -> [(Text, CensusStats)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Text, CensusStats) -> (Text, CensusStats) -> Ordering)
-> (Text, CensusStats) -> (Text, CensusStats) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Text, CensusStats) -> Size)
-> (Text, CensusStats) -> (Text, CensusStats) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (CensusStats -> Size
cssize (CensusStats -> Size)
-> ((Text, CensusStats) -> CensusStats)
-> (Text, CensusStats)
-> Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, CensusStats) -> CensusStats
forall a b. (a, b) -> b
snd))) (CensusByClosureType -> [(Text, CensusStats)]
forall k a. Map k a -> [(k, a)]
Map.toList CensusByClosureType
c)
      showLine :: (Text, CensusStats) -> String
showLine (Text
k, CS (Count Int
n) (Size Int
s) (Max (Size Int
mn))) =
        [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Text -> String
unpack Text
k, String
":", Int -> String
forall a. Show a => a -> String
show Int
s,String
":", Int -> String
forall a. Show a => a -> String
show Int
n, String
":", Int -> String
forall a. Show a => a -> String
show Int
mn,String
":", forall a. Show a => a -> String
show @Double (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)]
  String -> String -> IO ()
writeFile String
outpath ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"key, total, count, max, avg" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((Text, CensusStats) -> String)
-> [(Text, CensusStats)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text, CensusStats) -> String
showLine [(Text, CensusStats)]
res)


{-
-- | Peform a profile at the given interval (in seconds), the result will
-- be rendered after each iteration using @eventlog2html@.
profile :: FilePath -> Int -> Debuggee -> IO ()
profile outpath interval e = loop [(0, Map.empty)] 0
  where
    loop :: [(Int, CensusByClosureType)] -> Int -> IO ()
    loop ss i = do
      threadDelay (interval * 1_000_000)
      pause e
      r <- runTrace e $ do
        precacheBlocks
        rs <- gcRoots
        traceWrite (length rs)
        census2LevelClosureType rs
      resume e
      writeCensusByClosureType outpath r
      let new_data = ((i + 1) * interval, r) : ss
      renderProfile new_data
      loop new_data (i + 1)


mkFrame :: (Int, CensusByClosureType) -> Frame
mkFrame (t, m) = Frame (fromIntegral t / 10e6) (Map.foldrWithKey (\k v r -> mkSample k v : r) [] m)

mkSample :: Text -> CensusStats -> Sample
mkSample k (CS _ (Size v) _) =
  Sample (Bucket k) (fromIntegral v)

mkProfData :: [(Int, CensusByClosureType)] -> ProfData
mkProfData raw_fs =
  let fs = map mkFrame raw_fs
      (counts, totals) = total fs
      -- Heap profiles don't contain any other information than the simple bucket name
      binfo = Map.mapWithKey (\(Bucket k) (t,s,g) -> BucketInfo k Nothing t s g) totals
  -- Heap profiles do not support traces
      header = Header "ghc-debug" "" (Just HeapProfBreakdownClosureType) "" "" "" counts Nothing
  in ProfData header binfo mempty fs [] (HeapInfo [] [] []) mempty

renderProfile :: [(Int, CensusByClosureType)] -> IO ()
renderProfile ss = do
  let pd = mkProfData ss
  Run as <- defaultArgs "unused"
  (header, data_json, descs, closure_descs) <- generateJsonData as pd
  let html = templateString header data_json descs closure_descs as
  writeFile "profile/ht.html" html
  return ()
  -}