{-# 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( 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 Control.Concurrent
import Eventlog.Types
import Eventlog.Data
import Eventlog.Total
import Eventlog.HtmlTemplate
import Eventlog.Args (defaultArgs)
import Data.Text (pack, Text, unpack)
import Data.Semigroup
import qualified Data.Text as T
import qualified Data.Map.Monoidal.Strict as MMap



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 PayloadCont ConstrDesc StackCont ClosurePtr
d <- (PayloadCont -> DebugM PayloadCont)
-> (ConstrDescCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM
     (DebugClosureWithExtra
        Size PayloadCont ConstrDesc StackCont ClosurePtr)
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 -> DebugM PayloadCont
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosurePtr -> DebugM ClosurePtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure SizedClosure
s
      let siz :: Size
          siz :: Size
siz = DebugClosureWithExtra
  Size PayloadCont ConstrDesc StackCont ClosurePtr
-> Size
forall pap string s b. DebugClosureWithSize pap string s b -> Size
dcSize DebugClosureWithExtra
  Size PayloadCont ConstrDesc StackCont ClosurePtr
d
          v :: CensusStats
v =  Size -> CensusStats
mkCS Size
siz
      Maybe (Text, CensusStats) -> DebugM (Maybe (Text, CensusStats))
forall (m :: * -> *) a. Monad m => a -> m 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 PayloadCont ConstrDesc StackCont ClosurePtr -> Text
forall a c d. DebugClosure a ConstrDesc c d -> Text
closureToKey (DebugClosureWithExtra
  Size PayloadCont ConstrDesc StackCont ClosurePtr
-> DebugClosure PayloadCont ConstrDesc StackCont ClosurePtr
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize DebugClosureWithExtra
  Size PayloadCont ConstrDesc StackCont ClosurePtr
d), CensusStats
v)



closureToKey :: DebugClosure a ConstrDesc c d -> Text
closureToKey :: forall a c d. DebugClosure a ConstrDesc c d -> Text
closureToKey DebugClosure a ConstrDesc c d
d =
  case DebugClosure a ConstrDesc c d
d of
     ConstrClosure { constrDesc :: forall pap string s b. DebugClosure 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 a ConstrDesc c d
_ -> String -> Text
pack (ClosureType -> String
forall a. Show a => a -> String
show (StgInfoTable -> ClosureType
tipe (StgInfoTableWithPtr -> StgInfoTable
decodedTable (DebugClosure a ConstrDesc c d -> StgInfoTableWithPtr
forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info DebugClosure 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 (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 (m :: * -> *) a. Monad m => a -> m a
return ())
              , stackTrace :: GenStackFrames ClosurePtr -> DebugM ()
stackTrace = DebugM () -> GenStackFrames ClosurePtr -> DebugM ()
forall a b. a -> b -> a
const (() -> DebugM ()
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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return ())
              , stackTrace :: GenStackFrames ClosurePtr -> StateT CensusByClosureType DebugM ()
stackTrace = StateT CensusByClosureType DebugM ()
-> GenStackFrames ClosurePtr
-> StateT CensusByClosureType DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusByClosureType DebugM ()
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 (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 (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
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames ClosurePtr)
  ClosurePtr
s' <- DebugM
  (DebugClosureWithExtra
     Size
     (GenPapPayload ClosurePtr)
     ConstrDesc
     (GenStackFrames ClosurePtr)
     ClosurePtr)
-> StateT
     CensusByClosureType
     DebugM
     (DebugClosureWithExtra
        Size
        (GenPapPayload ClosurePtr)
        ConstrDesc
        (GenStackFrames ClosurePtr)
        ClosurePtr)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM
   (DebugClosureWithExtra
      Size
      (GenPapPayload ClosurePtr)
      ConstrDesc
      (GenStackFrames ClosurePtr)
      ClosurePtr)
 -> StateT
      CensusByClosureType
      DebugM
      (DebugClosureWithExtra
         Size
         (GenPapPayload ClosurePtr)
         ConstrDesc
         (GenStackFrames ClosurePtr)
         ClosurePtr))
-> DebugM
     (DebugClosureWithExtra
        Size
        (GenPapPayload ClosurePtr)
        ConstrDesc
        (GenStackFrames ClosurePtr)
        ClosurePtr)
-> StateT
     CensusByClosureType
     DebugM
     (DebugClosureWithExtra
        Size
        (GenPapPayload ClosurePtr)
        ConstrDesc
        (GenStackFrames ClosurePtr)
        ClosurePtr)
forall a b. (a -> b) -> a -> b
$ (PayloadCont -> DebugM (GenPapPayload ClosurePtr))
-> (ConstrDescCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM (GenStackFrames ClosurePtr))
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM
     (DebugClosureWithExtra
        Size
        (GenPapPayload ClosurePtr)
        ConstrDesc
        (GenStackFrames ClosurePtr)
        ClosurePtr)
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 -> DebugM (GenPapPayload ClosurePtr)
dereferencePapPayload ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM (GenStackFrames ClosurePtr)
dereferenceStack ClosurePtr -> DebugM ClosurePtr
forall (f :: * -> *) a. Applicative f => a -> f a
pure SizedClosure
s
      [SizedClosure]
pts <- DebugM [SizedClosure]
-> StateT CensusByClosureType DebugM [SizedClosure]
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)
mapM ClosurePtr -> DebugM SizedClosure
dereferenceClosure (DebugClosure
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames ClosurePtr)
  ClosurePtr
-> [ClosurePtr]
forall c a.
DebugClosure (GenPapPayload c) a (GenStackFrames c) c -> [c]
allClosures (DebugClosureWithExtra
  Size
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames ClosurePtr)
  ClosurePtr
-> DebugClosure
     (GenPapPayload ClosurePtr)
     ConstrDesc
     (GenStackFrames ClosurePtr)
     ClosurePtr
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize DebugClosureWithExtra
  Size
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames ClosurePtr)
  ClosurePtr
s'))
      [DebugClosureWithExtra
   Size PayloadCont ConstrDesc StackCont ClosurePtr]
pts' <- DebugM
  [DebugClosureWithExtra
     Size PayloadCont ConstrDesc StackCont ClosurePtr]
-> StateT
     CensusByClosureType
     DebugM
     [DebugClosureWithExtra
        Size PayloadCont ConstrDesc StackCont ClosurePtr]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM
   [DebugClosureWithExtra
      Size PayloadCont ConstrDesc StackCont ClosurePtr]
 -> StateT
      CensusByClosureType
      DebugM
      [DebugClosureWithExtra
         Size PayloadCont ConstrDesc StackCont ClosurePtr])
-> DebugM
     [DebugClosureWithExtra
        Size PayloadCont ConstrDesc StackCont ClosurePtr]
-> StateT
     CensusByClosureType
     DebugM
     [DebugClosureWithExtra
        Size PayloadCont ConstrDesc StackCont ClosurePtr]
forall a b. (a -> b) -> a -> b
$ (SizedClosure
 -> DebugM
      (DebugClosureWithExtra
         Size PayloadCont ConstrDesc StackCont ClosurePtr))
-> [SizedClosure]
-> DebugM
     [DebugClosureWithExtra
        Size PayloadCont ConstrDesc StackCont ClosurePtr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((PayloadCont -> DebugM PayloadCont)
-> (ConstrDescCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM
     (DebugClosureWithExtra
        Size PayloadCont ConstrDesc StackCont ClosurePtr)
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 -> DebugM PayloadCont
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosurePtr -> DebugM ClosurePtr
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
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames ClosurePtr)
  ClosurePtr
-> [DebugClosureWithExtra
      Size PayloadCont ConstrDesc StackCont ClosurePtr]
-> CensusByClosureType
-> CensusByClosureType
forall {pap} {s} {b} {a} {c} {d}.
DebugClosureWithSize pap ConstrDesc s b
-> [DebugClosureWithSize a ConstrDesc c d]
-> CensusByClosureType
-> CensusByClosureType
go DebugClosureWithExtra
  Size
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames ClosurePtr)
  ClosurePtr
s' [DebugClosureWithExtra
   Size PayloadCont ConstrDesc StackCont ClosurePtr]
pts')
      StateT CensusByClosureType DebugM ()
k

    go :: DebugClosureWithSize pap ConstrDesc s b
-> [DebugClosureWithSize a ConstrDesc c d]
-> CensusByClosureType
-> CensusByClosureType
go DebugClosureWithSize pap ConstrDesc s b
d [DebugClosureWithSize a ConstrDesc c d]
args =
      let k :: Text
k = DebugClosure pap ConstrDesc s b -> Text
forall a c d. DebugClosure a ConstrDesc c d -> Text
closureToKey (DebugClosureWithSize pap ConstrDesc s b
-> DebugClosure pap ConstrDesc s b
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize DebugClosureWithSize pap ConstrDesc s b
d)
          kargs :: [Text]
kargs = (DebugClosureWithSize a ConstrDesc c d -> Text)
-> [DebugClosureWithSize a ConstrDesc c d] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (DebugClosure a ConstrDesc c d -> Text
forall a c d. DebugClosure a ConstrDesc c d -> Text
closureToKey (DebugClosure a ConstrDesc c d -> Text)
-> (DebugClosureWithSize a ConstrDesc c d
    -> DebugClosure a ConstrDesc c d)
-> DebugClosureWithSize a ConstrDesc c d
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosureWithSize a ConstrDesc c d
-> DebugClosure a ConstrDesc c d
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize) [DebugClosureWithSize 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 pap ConstrDesc s b -> Size
forall pap string s b. DebugClosureWithSize pap string s b -> Size
dcSize DebugClosureWithSize 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 <- quadtraverse 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 :: String -> Int -> Debuggee -> IO ()
profile String
outpath Int
interval Debuggee
e = [(Int, CensusByClosureType)] -> Int -> IO ()
loop [(Int
0, CensusByClosureType
forall k a. Map k a
Map.empty)] Int
0
  where
    loop :: [(Int, CensusByClosureType)] -> Int -> IO ()
    loop :: [(Int, CensusByClosureType)] -> Int -> IO ()
loop [(Int, CensusByClosureType)]
ss Int
i = do
      Int -> IO ()
threadDelay (Int
interval Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000)
      Debuggee -> IO ()
pause Debuggee
e
      CensusByClosureType
r <- Debuggee -> DebugM CensusByClosureType -> IO CensusByClosureType
forall a. Debuggee -> DebugM a -> IO a
runTrace Debuggee
e (DebugM CensusByClosureType -> IO CensusByClosureType)
-> DebugM CensusByClosureType -> IO CensusByClosureType
forall a b. (a -> b) -> a -> b
$ do
        DebugM [RawBlock]
precacheBlocks
        [ClosurePtr]
rs <- DebugM [ClosurePtr]
gcRoots
        Int -> DebugM ()
forall (m :: * -> *) a. (DebugMonad m, Show a) => a -> m ()
traceWrite ([ClosurePtr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClosurePtr]
rs)
        [ClosurePtr] -> DebugM CensusByClosureType
census2LevelClosureType [ClosurePtr]
rs
      Debuggee -> IO ()
resume Debuggee
e
      String -> CensusByClosureType -> IO ()
writeCensusByClosureType String
outpath CensusByClosureType
r
      let new_data :: [(Int, CensusByClosureType)]
new_data = ((Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
interval, CensusByClosureType
r) (Int, CensusByClosureType)
-> [(Int, CensusByClosureType)] -> [(Int, CensusByClosureType)]
forall a. a -> [a] -> [a]
: [(Int, CensusByClosureType)]
ss
      [(Int, CensusByClosureType)] -> IO ()
renderProfile [(Int, CensusByClosureType)]
new_data
      [(Int, CensusByClosureType)] -> Int -> IO ()
loop [(Int, CensusByClosureType)]
new_data (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)


mkFrame :: (Int, CensusByClosureType) -> Frame
mkFrame :: (Int, CensusByClosureType) -> Frame
mkFrame (Int
t, CensusByClosureType
m) = Double -> [Sample] -> Frame
Frame (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
10e6) ((Text -> CensusStats -> [Sample] -> [Sample])
-> [Sample] -> CensusByClosureType -> [Sample]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\Text
k CensusStats
v [Sample]
r -> Text -> CensusStats -> Sample
mkSample Text
k CensusStats
v Sample -> [Sample] -> [Sample]
forall a. a -> [a] -> [a]
: [Sample]
r) [] CensusByClosureType
m)

mkSample :: Text -> CensusStats -> Sample
mkSample :: Text -> CensusStats -> Sample
mkSample Text
k (CS Count
_ (Size Int
v) Max Size
_) =
  Bucket -> Double -> Sample
Sample (Text -> Bucket
Bucket Text
k) (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
v)

mkProfData :: [(Int, CensusByClosureType)] -> ProfData
mkProfData :: [(Int, CensusByClosureType)] -> ProfData
mkProfData [(Int, CensusByClosureType)]
raw_fs =
  let fs :: [Frame]
fs = ((Int, CensusByClosureType) -> Frame)
-> [(Int, CensusByClosureType)] -> [Frame]
forall a b. (a -> b) -> [a] -> [b]
map (Int, CensusByClosureType) -> Frame
mkFrame [(Int, CensusByClosureType)]
raw_fs
      (Int
counts, Map Bucket (Double, Double, Maybe (Double, Double, Double))
totals) = [Frame]
-> (Int,
    Map Bucket (Double, Double, Maybe (Double, Double, Double)))
total [Frame]
fs
      -- Heap profiles don't contain any other information than the simple bucket name
      binfo :: Map Bucket BucketInfo
binfo = (Bucket
 -> (Double, Double, Maybe (Double, Double, Double)) -> BucketInfo)
-> Map Bucket (Double, Double, Maybe (Double, Double, Double))
-> Map Bucket BucketInfo
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\(Bucket Text
k) (Double
t,Double
s,Maybe (Double, Double, Double)
g) -> Text
-> Maybe [Word32]
-> Double
-> Double
-> Maybe (Double, Double, Double)
-> BucketInfo
BucketInfo Text
k Maybe [Word32]
forall a. Maybe a
Nothing Double
t Double
s Maybe (Double, Double, Double)
g) Map Bucket (Double, Double, Maybe (Double, Double, Double))
totals
  -- Heap profiles do not support traces
      header :: Header
header = Text
-> Text
-> Maybe HeapProfBreakdown
-> Text
-> Text
-> Text
-> Int
-> Maybe String
-> Header
Header Text
"ghc-debug" Text
"" (HeapProfBreakdown -> Maybe HeapProfBreakdown
forall a. a -> Maybe a
Just HeapProfBreakdown
HeapProfBreakdownClosureType) Text
"" Text
"" Text
"" Int
counts Maybe String
forall a. Maybe a
Nothing
  in Header
-> Map Bucket BucketInfo
-> Map Word32 CostCentre
-> [Frame]
-> [Trace]
-> HeapInfo
-> Map InfoTablePtr InfoTableLoc
-> ProfData
ProfData Header
header Map Bucket BucketInfo
binfo Map Word32 CostCentre
forall a. Monoid a => a
mempty [Frame]
fs [] ([HeapSample] -> [HeapSample] -> [HeapSample] -> HeapInfo
HeapInfo [] [] []) Map InfoTablePtr InfoTableLoc
forall a. Monoid a => a
mempty

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