{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}

{- | Functions for performing whole heap census in the style of the normal
- heap profiling -}
module GHC.Debug.Profile( censusClosureType
                        , census2LevelClosureType
                        , closureCensusBy
                        , CensusByClosureType
                        , writeCensusByClosureType
                        , CensusStats(..)
                        , ProfileKey(..)
                        , ProfileKeyArgs(..)
                        , prettyProfileKey
                        , prettyShortProfileKey
                        , prettyProfileKeyArgs
                        , prettyProfileKeyArgs'
                        , prettyShortProfileKeyArgs
                        , mkCS
                        , Count(..)
                        , closureToKey
                        , ConstrDescText
                        , packConstrDesc
                        , pkgsText
                        , modlText
                        , nameText
                        ) 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.Strict
import Data.List (sortBy)
import Data.Ord
import Data.Text (pack, Text)
import Data.Semigroup
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Map.Monoidal.Strict as MMap
import Data.Bitraversable
import Control.Monad
import qualified Data.Set as Set
import qualified Data.Vector as V

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

type CensusByClosureType = Map.Map (ProfileKey, ProfileKeyArgs) 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 ((ProfileKey, ProfileKeyArgs), 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 ((ProfileKey, ProfileKeyArgs), CensusStats))
go
  where
    go :: ClosurePtr -> SizedClosure
       -> DebugM (Maybe ((ProfileKey, ProfileKeyArgs), CensusStats))
    go :: ClosurePtr
-> SizedClosure
-> DebugM (Maybe ((ProfileKey, ProfileKeyArgs), CensusStats))
go ClosurePtr
cp SizedClosure
s = do
      DebugClosureWithExtra
  Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
d <- (CCSPtr -> DebugM CCSPtr)
-> (SrtCont -> DebugM SrtCont)
-> (PayloadCont -> DebugM PayloadCont)
-> (SrtCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM
     (DebugClosureWithExtra
        Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
forall (f :: * -> *) a b c d e g h i j k l n.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> DebugClosureWithExtra Size a c e h j l
-> f (DebugClosureWithExtra Size b d g i k n)
forall (m :: * -> * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d
       e g h i j k l n.
(Hextraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> m a c e h j l
-> f (m b d g i k n)
hextraverse CCSPtr -> DebugM CCSPtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> Size
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b -> Size
dcSize DebugClosureWithExtra
  Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
d
          v :: CensusStats
v =  ClosurePtr -> Size -> CensusStats
mkCS ClosurePtr
cp Size
siz
      Maybe ((ProfileKey, ProfileKeyArgs), CensusStats)
-> DebugM (Maybe ((ProfileKey, ProfileKeyArgs), CensusStats))
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Maybe ((ProfileKey, ProfileKeyArgs), CensusStats)
 -> DebugM (Maybe ((ProfileKey, ProfileKeyArgs), CensusStats)))
-> Maybe ((ProfileKey, ProfileKeyArgs), CensusStats)
-> DebugM (Maybe ((ProfileKey, ProfileKeyArgs), CensusStats))
forall a b. (a -> b) -> a -> b
$ ((ProfileKey, ProfileKeyArgs), CensusStats)
-> Maybe ((ProfileKey, ProfileKeyArgs), CensusStats)
forall a. a -> Maybe a
Just ((DebugClosure
  CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> ProfileKey
forall ccs srt a c d.
DebugClosure ccs srt a ConstrDesc c d -> ProfileKey
closureToProfileKey (DebugClosureWithExtra
  Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> DebugClosure
     CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize DebugClosureWithExtra
  Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
d), ProfileKeyArgs
NoArgs), CensusStats
v)

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

-- | 'ConstrDescText' wraps a 'ConstrDesc' but is backed by a 'Text'.
--
-- More efficient to keep around than 'ConstrDesc'.
newtype ConstrDescText = ConstrDescText
  { ConstrDescText -> Text
descText :: Text
    -- ^ Contains the name, module name and package name. Values are separated by ';'.
  } deriving (Int -> ConstrDescText -> ShowS
[ConstrDescText] -> ShowS
ConstrDescText -> [Char]
(Int -> ConstrDescText -> ShowS)
-> (ConstrDescText -> [Char])
-> ([ConstrDescText] -> ShowS)
-> Show ConstrDescText
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConstrDescText -> ShowS
showsPrec :: Int -> ConstrDescText -> ShowS
$cshow :: ConstrDescText -> [Char]
show :: ConstrDescText -> [Char]
$cshowList :: [ConstrDescText] -> ShowS
showList :: [ConstrDescText] -> ShowS
Show, Eq ConstrDescText
Eq ConstrDescText =>
(ConstrDescText -> ConstrDescText -> Ordering)
-> (ConstrDescText -> ConstrDescText -> Bool)
-> (ConstrDescText -> ConstrDescText -> Bool)
-> (ConstrDescText -> ConstrDescText -> Bool)
-> (ConstrDescText -> ConstrDescText -> Bool)
-> (ConstrDescText -> ConstrDescText -> ConstrDescText)
-> (ConstrDescText -> ConstrDescText -> ConstrDescText)
-> Ord ConstrDescText
ConstrDescText -> ConstrDescText -> Bool
ConstrDescText -> ConstrDescText -> Ordering
ConstrDescText -> ConstrDescText -> ConstrDescText
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ConstrDescText -> ConstrDescText -> Ordering
compare :: ConstrDescText -> ConstrDescText -> Ordering
$c< :: ConstrDescText -> ConstrDescText -> Bool
< :: ConstrDescText -> ConstrDescText -> Bool
$c<= :: ConstrDescText -> ConstrDescText -> Bool
<= :: ConstrDescText -> ConstrDescText -> Bool
$c> :: ConstrDescText -> ConstrDescText -> Bool
> :: ConstrDescText -> ConstrDescText -> Bool
$c>= :: ConstrDescText -> ConstrDescText -> Bool
>= :: ConstrDescText -> ConstrDescText -> Bool
$cmax :: ConstrDescText -> ConstrDescText -> ConstrDescText
max :: ConstrDescText -> ConstrDescText -> ConstrDescText
$cmin :: ConstrDescText -> ConstrDescText -> ConstrDescText
min :: ConstrDescText -> ConstrDescText -> ConstrDescText
Ord, ConstrDescText -> ConstrDescText -> Bool
(ConstrDescText -> ConstrDescText -> Bool)
-> (ConstrDescText -> ConstrDescText -> Bool) -> Eq ConstrDescText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConstrDescText -> ConstrDescText -> Bool
== :: ConstrDescText -> ConstrDescText -> Bool
$c/= :: ConstrDescText -> ConstrDescText -> Bool
/= :: ConstrDescText -> ConstrDescText -> Bool
Eq)

pkgsText :: ConstrDescText -> Text
pkgsText :: ConstrDescText -> Text
pkgsText ConstrDescText
desc = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
";" (ConstrDescText -> Text
descText ConstrDescText
desc) of
  Text
_:Text
_:Text
pkgs:[Text]
_ -> Text
pkgs
  [Text]
_ -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"pkgsText: invariant violation: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (ConstrDescText -> Text
descText ConstrDescText
desc)


modlText :: ConstrDescText -> Text
modlText :: ConstrDescText -> Text
modlText ConstrDescText
desc = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
";" (ConstrDescText -> Text
descText ConstrDescText
desc) of
  Text
_:Text
modl:Text
_:[Text]
_ -> Text
modl
  [Text]
_ -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"modlText: invariant violation: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (ConstrDescText -> Text
descText ConstrDescText
desc)

nameText  :: ConstrDescText -> Text
nameText :: ConstrDescText -> Text
nameText ConstrDescText
desc = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
";" (ConstrDescText -> Text
descText ConstrDescText
desc) of
  Text
name:Text
_:Text
_:[Text]
_ -> Text
name
  [Text]
_ -> [Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"nameText: invariant violation: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (ConstrDescText -> Text
descText ConstrDescText
desc)

packConstrDesc :: ConstrDesc -> ConstrDescText
packConstrDesc :: ConstrDesc -> ConstrDescText
packConstrDesc ConstrDesc
constrDesc = ConstrDescText
  { descText :: Text
descText = Text -> [Text] -> Text
T.intercalate Text
";" [[Char] -> Text
T.pack (ConstrDesc -> [Char]
name ConstrDesc
constrDesc), [Char] -> Text
T.pack (ConstrDesc -> [Char]
modl ConstrDesc
constrDesc), [Char] -> Text
T.pack (ConstrDesc -> [Char]
pkg ConstrDesc
constrDesc)]
  }

data ProfileKey
  = ProfileConstrDesc !ConstrDescText
  | ProfileClosureDesc !Text
  deriving (Int -> ProfileKey -> ShowS
[ProfileKey] -> ShowS
ProfileKey -> [Char]
(Int -> ProfileKey -> ShowS)
-> (ProfileKey -> [Char])
-> ([ProfileKey] -> ShowS)
-> Show ProfileKey
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProfileKey -> ShowS
showsPrec :: Int -> ProfileKey -> ShowS
$cshow :: ProfileKey -> [Char]
show :: ProfileKey -> [Char]
$cshowList :: [ProfileKey] -> ShowS
showList :: [ProfileKey] -> ShowS
Show, Eq ProfileKey
Eq ProfileKey =>
(ProfileKey -> ProfileKey -> Ordering)
-> (ProfileKey -> ProfileKey -> Bool)
-> (ProfileKey -> ProfileKey -> Bool)
-> (ProfileKey -> ProfileKey -> Bool)
-> (ProfileKey -> ProfileKey -> Bool)
-> (ProfileKey -> ProfileKey -> ProfileKey)
-> (ProfileKey -> ProfileKey -> ProfileKey)
-> Ord ProfileKey
ProfileKey -> ProfileKey -> Bool
ProfileKey -> ProfileKey -> Ordering
ProfileKey -> ProfileKey -> ProfileKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ProfileKey -> ProfileKey -> Ordering
compare :: ProfileKey -> ProfileKey -> Ordering
$c< :: ProfileKey -> ProfileKey -> Bool
< :: ProfileKey -> ProfileKey -> Bool
$c<= :: ProfileKey -> ProfileKey -> Bool
<= :: ProfileKey -> ProfileKey -> Bool
$c> :: ProfileKey -> ProfileKey -> Bool
> :: ProfileKey -> ProfileKey -> Bool
$c>= :: ProfileKey -> ProfileKey -> Bool
>= :: ProfileKey -> ProfileKey -> Bool
$cmax :: ProfileKey -> ProfileKey -> ProfileKey
max :: ProfileKey -> ProfileKey -> ProfileKey
$cmin :: ProfileKey -> ProfileKey -> ProfileKey
min :: ProfileKey -> ProfileKey -> ProfileKey
Ord, ProfileKey -> ProfileKey -> Bool
(ProfileKey -> ProfileKey -> Bool)
-> (ProfileKey -> ProfileKey -> Bool) -> Eq ProfileKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProfileKey -> ProfileKey -> Bool
== :: ProfileKey -> ProfileKey -> Bool
$c/= :: ProfileKey -> ProfileKey -> Bool
/= :: ProfileKey -> ProfileKey -> Bool
Eq)

-- | Show the full 'ProfileKey', including package and module locations if available.
prettyProfileKey :: ProfileKey -> Text
prettyProfileKey :: ProfileKey -> Text
prettyProfileKey (ProfileClosureDesc Text
k) = Text
k
prettyProfileKey (ProfileConstrDesc ConstrDescText
desc) = ConstrDescText -> Text
pkgsText ConstrDescText
desc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConstrDescText -> Text
modlText ConstrDescText
desc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConstrDescText -> Text
nameText ConstrDescText
desc

-- | Show the 'ProfileKey' in a shortened form if possible.
-- For example, it omits package and module locations for 'ProfileConstrDesc'.
prettyShortProfileKey :: ProfileKey -> Text
prettyShortProfileKey :: ProfileKey -> Text
prettyShortProfileKey (ProfileClosureDesc Text
k) = Text
k
prettyShortProfileKey (ProfileConstrDesc ConstrDescText
desc) = ConstrDescText -> Text
nameText ConstrDescText
desc

closureToProfileKey :: DebugClosure ccs srt a ConstrDesc c d -> ProfileKey
closureToProfileKey :: forall ccs srt a c d.
DebugClosure ccs srt a ConstrDesc c d -> ProfileKey
closureToProfileKey DebugClosure ccs srt a ConstrDesc c d
d =
  case DebugClosure ccs srt a ConstrDesc c d
d of
     ConstrClosure { constrDesc :: forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> string
constrDesc = ConstrDesc
constrDesc } -> ConstrDescText -> ProfileKey
ProfileConstrDesc (ConstrDescText -> ProfileKey) -> ConstrDescText -> ProfileKey
forall a b. (a -> b) -> a -> b
$ ConstrDesc -> ConstrDescText
packConstrDesc ConstrDesc
constrDesc
     DebugClosure ccs srt a ConstrDesc c d
_ -> Text -> ProfileKey
ProfileClosureDesc (Text -> ProfileKey) -> Text -> ProfileKey
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack (ClosureType -> [Char]
forall a. Show a => a -> [Char]
show (StgInfoTable -> ClosureType
tipe (StgInfoTableWithPtr -> StgInfoTable
decodedTable (DebugClosure ccs srt a ConstrDesc c d -> StgInfoTableWithPtr
forall ccs srt pap string s b.
DebugClosure ccs srt pap string s b -> StgInfoTableWithPtr
info DebugClosure ccs srt a ConstrDesc c d
d))))
data ProfileKeyArgs
  = ArrKeyArgs !ProfileKey !Int
  | AllKeyArgs !(V.Vector ProfileKey)
  | NoArgs
  deriving (Int -> ProfileKeyArgs -> ShowS
[ProfileKeyArgs] -> ShowS
ProfileKeyArgs -> [Char]
(Int -> ProfileKeyArgs -> ShowS)
-> (ProfileKeyArgs -> [Char])
-> ([ProfileKeyArgs] -> ShowS)
-> Show ProfileKeyArgs
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProfileKeyArgs -> ShowS
showsPrec :: Int -> ProfileKeyArgs -> ShowS
$cshow :: ProfileKeyArgs -> [Char]
show :: ProfileKeyArgs -> [Char]
$cshowList :: [ProfileKeyArgs] -> ShowS
showList :: [ProfileKeyArgs] -> ShowS
Show, Eq ProfileKeyArgs
Eq ProfileKeyArgs =>
(ProfileKeyArgs -> ProfileKeyArgs -> Ordering)
-> (ProfileKeyArgs -> ProfileKeyArgs -> Bool)
-> (ProfileKeyArgs -> ProfileKeyArgs -> Bool)
-> (ProfileKeyArgs -> ProfileKeyArgs -> Bool)
-> (ProfileKeyArgs -> ProfileKeyArgs -> Bool)
-> (ProfileKeyArgs -> ProfileKeyArgs -> ProfileKeyArgs)
-> (ProfileKeyArgs -> ProfileKeyArgs -> ProfileKeyArgs)
-> Ord ProfileKeyArgs
ProfileKeyArgs -> ProfileKeyArgs -> Bool
ProfileKeyArgs -> ProfileKeyArgs -> Ordering
ProfileKeyArgs -> ProfileKeyArgs -> ProfileKeyArgs
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ProfileKeyArgs -> ProfileKeyArgs -> Ordering
compare :: ProfileKeyArgs -> ProfileKeyArgs -> Ordering
$c< :: ProfileKeyArgs -> ProfileKeyArgs -> Bool
< :: ProfileKeyArgs -> ProfileKeyArgs -> Bool
$c<= :: ProfileKeyArgs -> ProfileKeyArgs -> Bool
<= :: ProfileKeyArgs -> ProfileKeyArgs -> Bool
$c> :: ProfileKeyArgs -> ProfileKeyArgs -> Bool
> :: ProfileKeyArgs -> ProfileKeyArgs -> Bool
$c>= :: ProfileKeyArgs -> ProfileKeyArgs -> Bool
>= :: ProfileKeyArgs -> ProfileKeyArgs -> Bool
$cmax :: ProfileKeyArgs -> ProfileKeyArgs -> ProfileKeyArgs
max :: ProfileKeyArgs -> ProfileKeyArgs -> ProfileKeyArgs
$cmin :: ProfileKeyArgs -> ProfileKeyArgs -> ProfileKeyArgs
min :: ProfileKeyArgs -> ProfileKeyArgs -> ProfileKeyArgs
Ord, ProfileKeyArgs -> ProfileKeyArgs -> Bool
(ProfileKeyArgs -> ProfileKeyArgs -> Bool)
-> (ProfileKeyArgs -> ProfileKeyArgs -> Bool) -> Eq ProfileKeyArgs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProfileKeyArgs -> ProfileKeyArgs -> Bool
== :: ProfileKeyArgs -> ProfileKeyArgs -> Bool
$c/= :: ProfileKeyArgs -> ProfileKeyArgs -> Bool
/= :: ProfileKeyArgs -> ProfileKeyArgs -> Bool
Eq)

prettyProfileKeyArgs :: ProfileKeyArgs -> Text
prettyProfileKeyArgs :: ProfileKeyArgs -> Text
prettyProfileKeyArgs = (ProfileKey -> Text) -> ProfileKeyArgs -> Text
prettyProfileKeyArgs' ProfileKey -> Text
prettyProfileKey

prettyShortProfileKeyArgs :: ProfileKeyArgs -> Text
prettyShortProfileKeyArgs :: ProfileKeyArgs -> Text
prettyShortProfileKeyArgs = (ProfileKey -> Text) -> ProfileKeyArgs -> Text
prettyProfileKeyArgs' ProfileKey -> Text
prettyShortProfileKey

prettyProfileKeyArgs' :: (ProfileKey -> Text) -> ProfileKeyArgs -> Text
prettyProfileKeyArgs' :: (ProfileKey -> Text) -> ProfileKeyArgs -> Text
prettyProfileKeyArgs' ProfileKey -> Text
prettyKey (ArrKeyArgs ProfileKey
typ Int
num) = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ProfileKey -> Text
prettyKey ProfileKey
typ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
num) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
prettyProfileKeyArgs' ProfileKey -> Text
prettyKey (AllKeyArgs Vector ProfileKey
args) = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"," ((ProfileKey -> Text) -> [ProfileKey] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ProfileKey -> Text
prettyKey ([ProfileKey] -> [Text]) -> [ProfileKey] -> [Text]
forall a b. (a -> b) -> a -> b
$ Vector ProfileKey -> [ProfileKey]
forall a. Vector a -> [a]
V.toList Vector ProfileKey
args) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
prettyProfileKeyArgs' ProfileKey -> Text
_  ProfileKeyArgs
NoArgs = Text
""

-- | 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
              , visitedClosVal :: ClosurePtr -> () -> DebugM (MonoidalMap k v)
visitedClosVal = (() -> 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))
              , visitedCcsVal :: CCSPtr -> DebugM (MonoidalMap k v)
visitedCcsVal = DebugM (MonoidalMap k v) -> CCSPtr -> 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 ())
              , ccsTrace :: CCSPtr -> CCSPayload -> DebugM (MonoidalMap k v)
ccsTrace = (CCSPayload -> DebugM (MonoidalMap k v))
-> CCSPtr -> CCSPayload -> DebugM (MonoidalMap k v)
forall a b. a -> b -> a
const (DebugM (MonoidalMap k v) -> CCSPayload -> 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 a. Monoid a => a
mempty))
            }
    -- 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 = (ClosurePtr
 -> SizedClosure
 -> StateT CensusByClosureType DebugM ()
 -> StateT CensusByClosureType DebugM ())
-> TraceFunctions (StateT CensusByClosureType)
forall (m :: (* -> *) -> * -> *).
C m =>
(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())
-> TraceFunctions m
justClosures ClosurePtr
-> SizedClosure
-> StateT CensusByClosureType DebugM ()
-> StateT CensusByClosureType DebugM ()
closAccum
    -- Add cos
    closAccum  :: ClosurePtr
               -> SizedClosure
               -> (StateT CensusByClosureType DebugM) ()
               -> (StateT CensusByClosureType DebugM) ()
    closAccum :: ClosurePtr
-> SizedClosure
-> StateT CensusByClosureType DebugM ()
-> StateT CensusByClosureType DebugM ()
closAccum ClosurePtr
cp SizedClosure
s StateT CensusByClosureType DebugM ()
k = do
      DebugClosureWithExtra
  Size
  CCSPtr
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
s' <- DebugM
  (DebugClosureWithExtra
     Size
     CCSPtr
     (GenSrtPayload ClosurePtr)
     (GenPapPayload ClosurePtr)
     ConstrDesc
     (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
     ClosurePtr)
-> StateT
     CensusByClosureType
     DebugM
     (DebugClosureWithExtra
        Size
        CCSPtr
        (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
      CCSPtr
      (GenSrtPayload ClosurePtr)
      (GenPapPayload ClosurePtr)
      ConstrDesc
      (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
      ClosurePtr)
 -> StateT
      CensusByClosureType
      DebugM
      (DebugClosureWithExtra
         Size
         CCSPtr
         (GenSrtPayload ClosurePtr)
         (GenPapPayload ClosurePtr)
         ConstrDesc
         (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
         ClosurePtr))
-> DebugM
     (DebugClosureWithExtra
        Size
        CCSPtr
        (GenSrtPayload ClosurePtr)
        (GenPapPayload ClosurePtr)
        ConstrDesc
        (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
        ClosurePtr)
-> StateT
     CensusByClosureType
     DebugM
     (DebugClosureWithExtra
        Size
        CCSPtr
        (GenSrtPayload ClosurePtr)
        (GenPapPayload ClosurePtr)
        ConstrDesc
        (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
        ClosurePtr)
forall a b. (a -> b) -> a -> b
$ (CCSPtr -> DebugM CCSPtr)
-> (SrtCont -> DebugM (GenSrtPayload ClosurePtr))
-> (PayloadCont -> DebugM (GenPapPayload ClosurePtr))
-> (SrtCont -> DebugM ConstrDesc)
-> (StackCont
    -> DebugM (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr))
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM
     (DebugClosureWithExtra
        Size
        CCSPtr
        (GenSrtPayload ClosurePtr)
        (GenPapPayload ClosurePtr)
        ConstrDesc
        (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
        ClosurePtr)
forall (f :: * -> *) a b c d e g h i j k l n.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> DebugClosureWithExtra Size a c e h j l
-> f (DebugClosureWithExtra Size b d g i k n)
forall (m :: * -> * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d
       e g h i j k l n.
(Hextraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> m a c e h j l
-> f (m b d g i k n)
hextraverse CCSPtr -> DebugM CCSPtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
  CCSPtr
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
-> [ClosurePtr]
forall ccs c a.
DebugClosure
  ccs
  (GenSrtPayload c)
  (GenPapPayload c)
  a
  (GenStackFrames (GenSrtPayload c) c)
  c
-> [c]
allClosures (DebugClosureWithExtra
  Size
  CCSPtr
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
-> DebugClosure
     CCSPtr
     (GenSrtPayload ClosurePtr)
     (GenPapPayload ClosurePtr)
     ConstrDesc
     (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
     ClosurePtr
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize DebugClosureWithExtra
  Size
  CCSPtr
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
s'))
      [DebugClosureWithExtra
   Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
pts' <- DebugM
  [DebugClosureWithExtra
     Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
-> StateT
     CensusByClosureType
     DebugM
     [DebugClosureWithExtra
        Size CCSPtr 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 CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
 -> StateT
      CensusByClosureType
      DebugM
      [DebugClosureWithExtra
         Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr])
-> DebugM
     [DebugClosureWithExtra
        Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
-> StateT
     CensusByClosureType
     DebugM
     [DebugClosureWithExtra
        Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
forall a b. (a -> b) -> a -> b
$ (SizedClosure
 -> DebugM
      (DebugClosureWithExtra
         Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr))
-> [SizedClosure]
-> DebugM
     [DebugClosureWithExtra
        Size CCSPtr 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 ((CCSPtr -> DebugM CCSPtr)
-> (SrtCont -> DebugM SrtCont)
-> (PayloadCont -> DebugM PayloadCont)
-> (SrtCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM
     (DebugClosureWithExtra
        Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
forall (f :: * -> *) a b c d e g h i j k l n.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> DebugClosureWithExtra Size a c e h j l
-> f (DebugClosureWithExtra Size b d g i k n)
forall (m :: * -> * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d
       e g h i j k l n.
(Hextraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> m a c e h j l
-> f (m b d g i k n)
hextraverse CCSPtr -> DebugM CCSPtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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' (ClosurePtr
-> DebugClosureWithExtra
     Size
     CCSPtr
     (GenSrtPayload ClosurePtr)
     (GenPapPayload ClosurePtr)
     ConstrDesc
     (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
     ClosurePtr
-> [DebugClosureWithExtra
      Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
-> CensusByClosureType
-> CensusByClosureType
forall {ccs} {srt} {pap} {s} {b} {ccs} {srt} {a} {c} {d}.
ClosurePtr
-> DebugClosureWithSize ccs srt pap ConstrDesc s b
-> [DebugClosureWithSize ccs srt a ConstrDesc c d]
-> CensusByClosureType
-> CensusByClosureType
go ClosurePtr
cp DebugClosureWithExtra
  Size
  CCSPtr
  (GenSrtPayload ClosurePtr)
  (GenPapPayload ClosurePtr)
  ConstrDesc
  (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
  ClosurePtr
s' [DebugClosureWithExtra
   Size CCSPtr SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
pts')
      StateT CensusByClosureType DebugM ()
k

    closureArgsToKeyArgs :: ProfileKey -> [ProfileKey] -> ProfileKeyArgs
closureArgsToKeyArgs (ProfileClosureDesc Text
k) [ProfileKey]
kargs =
      if Text
k Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
mutArrConstants Bool -> Bool -> Bool
&& Set ProfileKey -> Int
forall a. Set a -> Int
Set.size ([ProfileKey] -> Set ProfileKey
forall a. Ord a => [a] -> Set a
Set.fromList [ProfileKey]
kargs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
        then ProfileKey -> Int -> ProfileKeyArgs
ArrKeyArgs ([ProfileKey] -> ProfileKey
forall a. HasCallStack => [a] -> a
head [ProfileKey]
kargs) ([ProfileKey] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ProfileKey]
kargs)
        else Vector ProfileKey -> ProfileKeyArgs
AllKeyArgs (Vector ProfileKey -> ProfileKeyArgs)
-> Vector ProfileKey -> ProfileKeyArgs
forall a b. (a -> b) -> a -> b
$! [ProfileKey] -> Vector ProfileKey
forall a. [a] -> Vector a
V.fromList [ProfileKey]
kargs
    closureArgsToKeyArgs (ProfileConstrDesc ConstrDescText
_) [ProfileKey]
kargs =
      Vector ProfileKey -> ProfileKeyArgs
AllKeyArgs (Vector ProfileKey -> ProfileKeyArgs)
-> Vector ProfileKey -> ProfileKeyArgs
forall a b. (a -> b) -> a -> b
$ [ProfileKey] -> Vector ProfileKey
forall a. [a] -> Vector a
V.fromList [ProfileKey]
kargs

    go :: ClosurePtr
-> DebugClosureWithSize ccs srt pap ConstrDesc s b
-> [DebugClosureWithSize ccs srt a ConstrDesc c d]
-> CensusByClosureType
-> CensusByClosureType
go ClosurePtr
cp DebugClosureWithSize ccs srt pap ConstrDesc s b
d [DebugClosureWithSize ccs srt a ConstrDesc c d]
args =
      let !k :: ProfileKey
k = DebugClosure ccs srt pap ConstrDesc s b -> ProfileKey
forall ccs srt a c d.
DebugClosure ccs srt a ConstrDesc c d -> ProfileKey
closureToProfileKey (DebugClosureWithSize ccs srt pap ConstrDesc s b
-> DebugClosure ccs srt pap ConstrDesc s b
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize DebugClosureWithSize ccs srt pap ConstrDesc s b
d)
          kargs :: [ProfileKey]
kargs = (DebugClosureWithSize ccs srt a ConstrDesc c d -> ProfileKey)
-> [DebugClosureWithSize ccs srt a ConstrDesc c d] -> [ProfileKey]
forall a b. (a -> b) -> [a] -> [b]
map (DebugClosure ccs srt a ConstrDesc c d -> ProfileKey
forall ccs srt a c d.
DebugClosure ccs srt a ConstrDesc c d -> ProfileKey
closureToProfileKey (DebugClosure ccs srt a ConstrDesc c d -> ProfileKey)
-> (DebugClosureWithSize ccs srt a ConstrDesc c d
    -> DebugClosure ccs srt a ConstrDesc c d)
-> DebugClosureWithSize ccs srt a ConstrDesc c d
-> ProfileKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosureWithSize ccs srt a ConstrDesc c d
-> DebugClosure ccs srt a ConstrDesc c d
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b
-> DebugClosure ccs srt pap string s b
noSize) [DebugClosureWithSize ccs srt a ConstrDesc c d]
args
          !keyArgs :: ProfileKeyArgs
keyArgs = ProfileKey -> [ProfileKey] -> ProfileKeyArgs
closureArgsToKeyArgs ProfileKey
k [ProfileKey]
kargs
      in (CensusStats -> CensusStats -> CensusStats)
-> (ProfileKey, ProfileKeyArgs)
-> 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
(<>) (ProfileKey
k, ProfileKeyArgs
keyArgs) (ClosurePtr -> Size -> CensusStats
mkCS ClosurePtr
cp (DebugClosureWithSize ccs srt pap ConstrDesc s b -> Size
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b -> Size
dcSize DebugClosureWithSize ccs srt pap ConstrDesc s b
d))

    -- We handle these closure types differently as they can list each entry as an arg.
    -- That leads to huge results, so we try to compress these closure types if and only if
    -- they describe a constructor homogenous array. Thus, it works well for product types
    -- but not for sum types.
    mutArrConstants :: Set Text
mutArrConstants = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (ClosureType -> Text) -> [ClosureType] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Text
T.pack ([Char] -> Text) -> (ClosureType -> [Char]) -> ClosureType -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClosureType -> [Char]
forall a. Show a => a -> [Char]
show)
      [ ClosureType
MUT_ARR_PTRS_CLEAN
      , ClosureType
MUT_ARR_PTRS_DIRTY
      , ClosureType
MUT_ARR_PTRS_FROZEN_DIRTY
      , ClosureType
MUT_ARR_PTRS_FROZEN_CLEAN
      , ClosureType
SMALL_MUT_ARR_PTRS_CLEAN
      , ClosureType
SMALL_MUT_ARR_PTRS_DIRTY
      , ClosureType
SMALL_MUT_ARR_PTRS_FROZEN_DIRTY
      , ClosureType
SMALL_MUT_ARR_PTRS_FROZEN_CLEAN
      ]

{-
-- | 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 <- hextraverse 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 :: [Char] -> CensusByClosureType -> IO ()
writeCensusByClosureType [Char]
outpath CensusByClosureType
c = do
  let res :: [((ProfileKey, ProfileKeyArgs), CensusStats)]
res = (((ProfileKey, ProfileKeyArgs), CensusStats)
 -> ((ProfileKey, ProfileKeyArgs), CensusStats) -> Ordering)
-> [((ProfileKey, ProfileKeyArgs), CensusStats)]
-> [((ProfileKey, ProfileKeyArgs), CensusStats)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((((ProfileKey, ProfileKeyArgs), CensusStats)
 -> ((ProfileKey, ProfileKeyArgs), CensusStats) -> Ordering)
-> ((ProfileKey, ProfileKeyArgs), CensusStats)
-> ((ProfileKey, ProfileKeyArgs), CensusStats)
-> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((((ProfileKey, ProfileKeyArgs), CensusStats) -> Size)
-> ((ProfileKey, ProfileKeyArgs), CensusStats)
-> ((ProfileKey, ProfileKeyArgs), CensusStats)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (CensusStats -> Size
cssize (CensusStats -> Size)
-> (((ProfileKey, ProfileKeyArgs), CensusStats) -> CensusStats)
-> ((ProfileKey, ProfileKeyArgs), CensusStats)
-> Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ProfileKey, ProfileKeyArgs), CensusStats) -> CensusStats
forall a b. (a, b) -> b
snd))) (CensusByClosureType
-> [((ProfileKey, ProfileKeyArgs), CensusStats)]
forall k a. Map k a -> [(k, a)]
Map.toList CensusByClosureType
c)
  [Char] -> Text -> IO ()
T.writeFile [Char]
outpath ([Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
"key; total; count; max; avg" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (((ProfileKey, ProfileKeyArgs), CensusStats) -> Text)
-> [((ProfileKey, ProfileKeyArgs), CensusStats)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((ProfileKey, ProfileKeyArgs), CensusStats) -> Text
showLine [((ProfileKey, ProfileKeyArgs), CensusStats)]
res)
  where
    separator :: Text
separator = Text
"; "
    showKey :: ProfileKey -> ProfileKeyArgs -> Text
showKey ProfileKey
k ProfileKeyArgs
args = ProfileKey -> Text
prettyProfileKey ProfileKey
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ProfileKeyArgs -> Text
prettyProfileKeyArgs ProfileKeyArgs
args
    showLine :: ((ProfileKey, ProfileKeyArgs), CensusStats) -> Text
showLine ((ProfileKey
k, ProfileKeyArgs
kargs), CS (Count Int
n) (Size Int
s) (Max (Size Int
mn)) Sample
_) =
      Text -> [Text] -> Text
T.intercalate Text
separator
        [ ProfileKey -> ProfileKeyArgs -> Text
showKey ProfileKey
k ProfileKeyArgs
kargs
        , [Char] -> Text
T.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
s)
        , [Char] -> Text
T.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n)
        , [Char] -> Text
T.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
mn)
        , [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
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))
        ]

{-
-- | 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 ()
  -}