{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RecordWildCards #-}
module GHC.Debug.Profile( censusClosureType
, census2LevelClosureType
, closureCensusBy
, CensusByClosureType
, writeCensusByClosureType
, CensusStats(..)
, mkCS
, Count(..)
, closureToKey ) where
import GHC.Debug.Client.Monad
import GHC.Debug.Client
import GHC.Debug.Trace
import GHC.Debug.ParTrace
import GHC.Debug.Profile.Types
import qualified Data.Map.Strict as Map
import Control.Monad.State
import Data.List (sortBy)
import Data.Ord
import Data.Text (pack, Text, unpack)
import Data.Semigroup
import qualified Data.Text as T
import qualified Data.Map.Monoidal.Strict as MMap
import Data.Bitraversable
import Control.Monad
type CensusByClosureType = Map.Map Text CensusStats
censusClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
censusClosureType :: [ClosurePtr] -> DebugM CensusByClosureType
censusClosureType = (ClosurePtr -> SizedClosure -> DebugM (Maybe (Text, CensusStats)))
-> [ClosurePtr] -> DebugM CensusByClosureType
forall k v.
(Semigroup v, Ord k) =>
(ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
-> [ClosurePtr] -> DebugM (Map k v)
closureCensusBy ClosurePtr -> SizedClosure -> DebugM (Maybe (Text, CensusStats))
go
where
go :: ClosurePtr -> SizedClosure
-> DebugM (Maybe (Text, CensusStats))
go :: ClosurePtr -> SizedClosure -> DebugM (Maybe (Text, CensusStats))
go ClosurePtr
_ SizedClosure
s = do
DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
d <- (SrtCont -> DebugM SrtCont)
-> (PayloadCont -> DebugM PayloadCont)
-> (SrtCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM
(DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
forall (f :: * -> *) a b c d e g h i j k.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> DebugClosureWithExtra Size a c e h j
-> f (DebugClosureWithExtra Size b d g i k)
forall (m :: * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d e g
h i j k.
(Quintraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> m a c e h j
-> f (m b d g i k)
quintraverse SrtCont -> DebugM SrtCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PayloadCont -> DebugM PayloadCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrtCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosurePtr -> DebugM ClosurePtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SizedClosure
s
let siz :: Size
siz :: Size
siz = DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> Size
forall srt pap string s b.
DebugClosureWithSize srt pap string s b -> Size
dcSize DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
d
v :: CensusStats
v = Size -> CensusStats
mkCS Size
siz
Maybe (Text, CensusStats) -> DebugM (Maybe (Text, CensusStats))
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
return (Maybe (Text, CensusStats) -> DebugM (Maybe (Text, CensusStats)))
-> Maybe (Text, CensusStats) -> DebugM (Maybe (Text, CensusStats))
forall a b. (a -> b) -> a -> b
$ (Text, CensusStats) -> Maybe (Text, CensusStats)
forall a. a -> Maybe a
Just (DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> Text
forall srt a c d. DebugClosure srt a ConstrDesc c d -> Text
closureToKey (DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
-> DebugClosure SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr
d), CensusStats
v)
closureToKey :: DebugClosure srt a ConstrDesc c d -> Text
closureToKey :: forall srt a c d. DebugClosure srt a ConstrDesc c d -> Text
closureToKey DebugClosure srt a ConstrDesc c d
d =
case DebugClosure srt a ConstrDesc c d
d of
ConstrClosure { constrDesc :: forall srt pap string s b.
DebugClosure srt pap string s b -> string
constrDesc = ConstrDesc String
a String
b String
c }
-> String -> Text
pack String
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
c
DebugClosure srt a ConstrDesc c d
_ -> String -> Text
pack (ClosureType -> String
forall a. Show a => a -> String
show (StgInfoTable -> ClosureType
tipe (StgInfoTableWithPtr -> StgInfoTable
decodedTable (DebugClosure srt a ConstrDesc c d -> StgInfoTableWithPtr
forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info DebugClosure srt a ConstrDesc c d
d))))
closureCensusBy :: forall k v . (Semigroup v, Ord k)
=> (ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
-> [ClosurePtr] -> DebugM (Map.Map k v)
closureCensusBy :: forall k v.
(Semigroup v, Ord k) =>
(ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v)))
-> [ClosurePtr] -> DebugM (Map k v)
closureCensusBy ClosurePtr -> SizedClosure -> DebugM (Maybe (k, v))
f [ClosurePtr]
cps = do
() () -> DebugM [RawBlock] -> DebugM ()
forall a b. a -> DebugM b -> DebugM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ DebugM [RawBlock]
precacheBlocks
MonoidalMap k v -> Map k v
forall k a. MonoidalMap k a -> Map k a
MMap.getMonoidalMap (MonoidalMap k v -> Map k v)
-> DebugM (MonoidalMap k v) -> DebugM (Map k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TraceFunctionsIO () (MonoidalMap k v)
-> [ClosurePtrWithInfo ()] -> DebugM (MonoidalMap k v)
forall s a.
Monoid s =>
TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s
traceParFromM TraceFunctionsIO () (MonoidalMap k v)
funcs ((ClosurePtr -> ClosurePtrWithInfo ())
-> [ClosurePtr] -> [ClosurePtrWithInfo ()]
forall a b. (a -> b) -> [a] -> [b]
map (() -> ClosurePtr -> ClosurePtrWithInfo ()
forall a. a -> ClosurePtr -> ClosurePtrWithInfo a
ClosurePtrWithInfo ()) [ClosurePtr]
cps)
where
funcs :: TraceFunctionsIO () (MonoidalMap k v)
funcs = TraceFunctionsIO {
papTrace :: GenPapPayload ClosurePtr -> DebugM ()
papTrace = DebugM () -> GenPapPayload ClosurePtr -> DebugM ()
forall a b. a -> b -> a
const (() -> DebugM ()
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, srtTrace :: GenSrtPayload ClosurePtr -> DebugM ()
srtTrace = DebugM () -> GenSrtPayload ClosurePtr -> DebugM ()
forall a b. a -> b -> a
const (() -> DebugM ()
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, stackTrace :: GenStackFrames SrtCont ClosurePtr -> DebugM ()
stackTrace = DebugM () -> GenStackFrames SrtCont ClosurePtr -> DebugM ()
forall a b. a -> b -> a
const (() -> DebugM ()
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, closTrace :: ClosurePtr
-> SizedClosure
-> ()
-> DebugM ((), MonoidalMap k v, DebugM () -> DebugM ())
closTrace = ClosurePtr
-> SizedClosure
-> ()
-> DebugM ((), MonoidalMap k v, DebugM () -> DebugM ())
forall a.
ClosurePtr
-> SizedClosure -> () -> DebugM ((), MonoidalMap k v, a -> a)
closAccum
, visitedVal :: ClosurePtr -> () -> DebugM (MonoidalMap k v)
visitedVal = (() -> DebugM (MonoidalMap k v))
-> ClosurePtr -> () -> DebugM (MonoidalMap k v)
forall a b. a -> b -> a
const (DebugM (MonoidalMap k v) -> () -> DebugM (MonoidalMap k v)
forall a b. a -> b -> a
const (MonoidalMap k v -> DebugM (MonoidalMap k v)
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return MonoidalMap k v
forall k a. MonoidalMap k a
MMap.empty))
, conDescTrace :: ConstrDesc -> DebugM ()
conDescTrace = DebugM () -> ConstrDesc -> DebugM ()
forall a b. a -> b -> a
const (() -> DebugM ()
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
}
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 = TraceFunctions {
papTrace :: GenPapPayload ClosurePtr -> StateT CensusByClosureType DebugM ()
papTrace = StateT CensusByClosureType DebugM ()
-> GenPapPayload ClosurePtr -> StateT CensusByClosureType DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusByClosureType DebugM ()
forall a. a -> StateT CensusByClosureType DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, srtTrace :: GenSrtPayload ClosurePtr -> StateT CensusByClosureType DebugM ()
srtTrace = StateT CensusByClosureType DebugM ()
-> GenSrtPayload ClosurePtr -> StateT CensusByClosureType DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusByClosureType DebugM ()
forall a. a -> StateT CensusByClosureType DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, stackTrace :: GenStackFrames SrtCont ClosurePtr
-> StateT CensusByClosureType DebugM ()
stackTrace = StateT CensusByClosureType DebugM ()
-> GenStackFrames SrtCont ClosurePtr
-> StateT CensusByClosureType DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusByClosureType DebugM ()
forall a. a -> StateT CensusByClosureType DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, closTrace :: ClosurePtr
-> SizedClosure
-> StateT CensusByClosureType DebugM ()
-> StateT CensusByClosureType DebugM ()
closTrace = ClosurePtr
-> SizedClosure
-> StateT CensusByClosureType DebugM ()
-> StateT CensusByClosureType DebugM ()
closAccum
, visitedVal :: ClosurePtr -> StateT CensusByClosureType DebugM ()
visitedVal = StateT CensusByClosureType DebugM ()
-> ClosurePtr -> StateT CensusByClosureType DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusByClosureType DebugM ()
forall a. a -> StateT CensusByClosureType DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, conDescTrace :: ConstrDesc -> StateT CensusByClosureType DebugM ()
conDescTrace = StateT CensusByClosureType DebugM ()
-> ConstrDesc -> StateT CensusByClosureType DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusByClosureType DebugM ()
forall a. a -> StateT CensusByClosureType DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
}
closAccum :: ClosurePtr
-> SizedClosure
-> (StateT CensusByClosureType DebugM) ()
-> (StateT CensusByClosureType DebugM) ()
closAccum :: ClosurePtr
-> SizedClosure
-> StateT CensusByClosureType DebugM ()
-> StateT CensusByClosureType DebugM ()
closAccum ClosurePtr
_ SizedClosure
s StateT CensusByClosureType DebugM ()
k = do
DebugClosureWithExtra
Size
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr
s' <- DebugM
(DebugClosureWithExtra
Size
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr)
-> StateT
CensusByClosureType
DebugM
(DebugClosureWithExtra
Size
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT CensusByClosureType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM
(DebugClosureWithExtra
Size
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr)
-> StateT
CensusByClosureType
DebugM
(DebugClosureWithExtra
Size
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr))
-> DebugM
(DebugClosureWithExtra
Size
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr)
-> StateT
CensusByClosureType
DebugM
(DebugClosureWithExtra
Size
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr)
forall a b. (a -> b) -> a -> b
$ (SrtCont -> DebugM (GenSrtPayload ClosurePtr))
-> (PayloadCont -> DebugM (GenPapPayload ClosurePtr))
-> (SrtCont -> DebugM ConstrDesc)
-> (StackCont
-> DebugM (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr))
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM
(DebugClosureWithExtra
Size
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr)
forall (f :: * -> *) a b c d e g h i j k.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> DebugClosureWithExtra Size a c e h j
-> f (DebugClosureWithExtra Size b d g i k)
forall (m :: * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d e g
h i j k.
(Quintraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> m a c e h j
-> f (m b d g i k)
quintraverse SrtCont -> DebugM (GenSrtPayload ClosurePtr)
dereferenceSRT PayloadCont -> DebugM (GenPapPayload ClosurePtr)
dereferencePapPayload SrtCont -> DebugM ConstrDesc
dereferenceConDesc ((SrtCont -> DebugM (GenSrtPayload ClosurePtr))
-> (ClosurePtr -> DebugM ClosurePtr)
-> GenStackFrames SrtCont ClosurePtr
-> DebugM (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c)
-> (b -> f d) -> GenStackFrames a b -> f (GenStackFrames c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse SrtCont -> DebugM (GenSrtPayload ClosurePtr)
dereferenceSRT ClosurePtr -> DebugM ClosurePtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenStackFrames SrtCont ClosurePtr
-> DebugM (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr))
-> (StackCont -> DebugM (GenStackFrames SrtCont ClosurePtr))
-> StackCont
-> DebugM (GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< StackCont -> DebugM (GenStackFrames SrtCont ClosurePtr)
dereferenceStack) ClosurePtr -> DebugM ClosurePtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SizedClosure
s
[SizedClosure]
pts <- DebugM [SizedClosure]
-> StateT CensusByClosureType DebugM [SizedClosure]
forall (m :: * -> *) a.
Monad m =>
m a -> StateT CensusByClosureType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM [SizedClosure]
-> StateT CensusByClosureType DebugM [SizedClosure])
-> DebugM [SizedClosure]
-> StateT CensusByClosureType DebugM [SizedClosure]
forall a b. (a -> b) -> a -> b
$ (ClosurePtr -> DebugM SizedClosure)
-> [ClosurePtr] -> DebugM [SizedClosure]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ClosurePtr -> DebugM SizedClosure
dereferenceClosure (DebugClosure
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr
-> [ClosurePtr]
forall c a.
DebugClosure
(GenSrtPayload c)
(GenPapPayload c)
a
(GenStackFrames (GenSrtPayload c) c)
c
-> [c]
allClosures (DebugClosureWithExtra
Size
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr
-> DebugClosure
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithExtra
Size
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr
s'))
[DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
pts' <- DebugM
[DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
-> StateT
CensusByClosureType
DebugM
[DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
forall (m :: * -> *) a.
Monad m =>
m a -> StateT CensusByClosureType m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM
[DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
-> StateT
CensusByClosureType
DebugM
[DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr])
-> DebugM
[DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
-> StateT
CensusByClosureType
DebugM
[DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
forall a b. (a -> b) -> a -> b
$ (SizedClosure
-> DebugM
(DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr))
-> [SizedClosure]
-> DebugM
[DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((SrtCont -> DebugM SrtCont)
-> (PayloadCont -> DebugM PayloadCont)
-> (SrtCont -> DebugM ConstrDesc)
-> (StackCont -> DebugM StackCont)
-> (ClosurePtr -> DebugM ClosurePtr)
-> SizedClosure
-> DebugM
(DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr)
forall (f :: * -> *) a b c d e g h i j k.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> DebugClosureWithExtra Size a c e h j
-> f (DebugClosureWithExtra Size b d g i k)
forall (m :: * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d e g
h i j k.
(Quintraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> m a c e h j
-> f (m b d g i k)
quintraverse SrtCont -> DebugM SrtCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PayloadCont -> DebugM PayloadCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrtCont -> DebugM ConstrDesc
dereferenceConDesc StackCont -> DebugM StackCont
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClosurePtr -> DebugM ClosurePtr
forall a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [SizedClosure]
pts
(CensusByClosureType -> CensusByClosureType)
-> StateT CensusByClosureType DebugM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (DebugClosureWithExtra
Size
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr
-> [DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
-> CensusByClosureType
-> CensusByClosureType
forall {srt} {pap} {s} {b} {srt} {a} {c} {d}.
DebugClosureWithSize srt pap ConstrDesc s b
-> [DebugClosureWithSize srt a ConstrDesc c d]
-> CensusByClosureType
-> CensusByClosureType
go DebugClosureWithExtra
Size
(GenSrtPayload ClosurePtr)
(GenPapPayload ClosurePtr)
ConstrDesc
(GenStackFrames (GenSrtPayload ClosurePtr) ClosurePtr)
ClosurePtr
s' [DebugClosureWithExtra
Size SrtCont PayloadCont ConstrDesc StackCont ClosurePtr]
pts')
StateT CensusByClosureType DebugM ()
k
go :: DebugClosureWithSize srt pap ConstrDesc s b
-> [DebugClosureWithSize srt a ConstrDesc c d]
-> CensusByClosureType
-> CensusByClosureType
go DebugClosureWithSize srt pap ConstrDesc s b
d [DebugClosureWithSize srt a ConstrDesc c d]
args =
let k :: Text
k = DebugClosure srt pap ConstrDesc s b -> Text
forall srt a c d. DebugClosure srt a ConstrDesc c d -> Text
closureToKey (DebugClosureWithSize srt pap ConstrDesc s b
-> DebugClosure srt pap ConstrDesc s b
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize DebugClosureWithSize srt pap ConstrDesc s b
d)
kargs :: [Text]
kargs = (DebugClosureWithSize srt a ConstrDesc c d -> Text)
-> [DebugClosureWithSize srt a ConstrDesc c d] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (DebugClosure srt a ConstrDesc c d -> Text
forall srt a c d. DebugClosure srt a ConstrDesc c d -> Text
closureToKey (DebugClosure srt a ConstrDesc c d -> Text)
-> (DebugClosureWithSize srt a ConstrDesc c d
-> DebugClosure srt a ConstrDesc c d)
-> DebugClosureWithSize srt a ConstrDesc c d
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugClosureWithSize srt a ConstrDesc c d
-> DebugClosure srt a ConstrDesc c d
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize) [DebugClosureWithSize srt a ConstrDesc c d]
args
final_k :: Text
final_k :: Text
final_k = Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"," [Text]
kargs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
in (CensusStats -> CensusStats -> CensusStats)
-> Text
-> CensusStats
-> CensusByClosureType
-> CensusByClosureType
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith CensusStats -> CensusStats -> CensusStats
forall a. Semigroup a => a -> a -> a
(<>) Text
final_k (Size -> CensusStats
mkCS (DebugClosureWithSize srt pap ConstrDesc s b -> Size
forall srt pap string s b.
DebugClosureWithSize srt pap string s b -> Size
dcSize DebugClosureWithSize srt pap ConstrDesc s b
d))
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)