{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
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
type CensusByClosureType = Map.Map (ProfileKey, ProfileKeyArgs) CensusStats
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))))
newtype ConstrDescText = ConstrDescText
{ ConstrDescText -> Text
descText :: Text
} 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)
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
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
""
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))
}
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
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
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))
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
]
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))
]