{-# LANGUAGE CPP #-}
module GHC.Stg.Stats ( showStgStats ) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Stg.Syntax
import GHC.Types.Id (Id)
import Data.Map (Map)
import qualified Data.Map as Map
data CounterType
= Literals
| Applications
| ConstructorApps
| PrimitiveApps
| LetNoEscapes
| StgCases
| FreeVariables
| ConstructorBinds Bool
| ReEntrantBinds Bool
| SingleEntryBinds Bool
| UpdatableBinds Bool
deriving (CounterType -> CounterType -> Bool
(CounterType -> CounterType -> Bool)
-> (CounterType -> CounterType -> Bool) -> Eq CounterType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CounterType -> CounterType -> Bool
$c/= :: CounterType -> CounterType -> Bool
== :: CounterType -> CounterType -> Bool
$c== :: CounterType -> CounterType -> Bool
Eq, Eq CounterType
Eq CounterType
-> (CounterType -> CounterType -> Ordering)
-> (CounterType -> CounterType -> Bool)
-> (CounterType -> CounterType -> Bool)
-> (CounterType -> CounterType -> Bool)
-> (CounterType -> CounterType -> Bool)
-> (CounterType -> CounterType -> CounterType)
-> (CounterType -> CounterType -> CounterType)
-> Ord CounterType
CounterType -> CounterType -> Bool
CounterType -> CounterType -> Ordering
CounterType -> CounterType -> CounterType
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
min :: CounterType -> CounterType -> CounterType
$cmin :: CounterType -> CounterType -> CounterType
max :: CounterType -> CounterType -> CounterType
$cmax :: CounterType -> CounterType -> CounterType
>= :: CounterType -> CounterType -> Bool
$c>= :: CounterType -> CounterType -> Bool
> :: CounterType -> CounterType -> Bool
$c> :: CounterType -> CounterType -> Bool
<= :: CounterType -> CounterType -> Bool
$c<= :: CounterType -> CounterType -> Bool
< :: CounterType -> CounterType -> Bool
$c< :: CounterType -> CounterType -> Bool
compare :: CounterType -> CounterType -> Ordering
$ccompare :: CounterType -> CounterType -> Ordering
Ord)
type Count = Int
type StatEnv = Map CounterType Count
emptySE :: StatEnv
emptySE :: StatEnv
emptySE = StatEnv
forall k a. Map k a
Map.empty
combineSE :: StatEnv -> StatEnv -> StatEnv
combineSE :: StatEnv -> StatEnv -> StatEnv
combineSE = (Count -> Count -> Count) -> StatEnv -> StatEnv -> StatEnv
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Count -> Count -> Count
forall a. Num a => a -> a -> a
(+)
combineSEs :: [StatEnv] -> StatEnv
combineSEs :: [StatEnv] -> StatEnv
combineSEs = (StatEnv -> StatEnv -> StatEnv) -> StatEnv -> [StatEnv] -> StatEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr StatEnv -> StatEnv -> StatEnv
combineSE StatEnv
emptySE
countOne :: CounterType -> StatEnv
countOne :: CounterType -> StatEnv
countOne CounterType
c = CounterType -> Count -> StatEnv
forall k a. k -> a -> Map k a
Map.singleton CounterType
c Count
1
showStgStats :: [StgTopBinding] -> String
showStgStats :: [StgTopBinding] -> String
showStgStats [StgTopBinding]
prog
= String
"STG Statistics:\n\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ ((CounterType, Count) -> String)
-> [(CounterType, Count)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CounterType, Count) -> String
forall {a}. Show a => (CounterType, a) -> String
showc (StatEnv -> [(CounterType, Count)]
forall k a. Map k a -> [(k, a)]
Map.toList ([StgTopBinding] -> StatEnv
gatherStgStats [StgTopBinding]
prog))
where
showc :: (CounterType, a) -> String
showc (CounterType
x,a
n) = (String -> String -> String
showString (CounterType -> String
s CounterType
x) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String -> String
forall a. Show a => a -> String -> String
shows a
n) String
"\n"
s :: CounterType -> String
s CounterType
Literals = String
"Literals "
s CounterType
Applications = String
"Applications "
s CounterType
ConstructorApps = String
"ConstructorApps "
s CounterType
PrimitiveApps = String
"PrimitiveApps "
s CounterType
LetNoEscapes = String
"LetNoEscapes "
s CounterType
StgCases = String
"StgCases "
s CounterType
FreeVariables = String
"FreeVariables "
s (ConstructorBinds Bool
True) = String
"ConstructorBinds_Top "
s (ReEntrantBinds Bool
True) = String
"ReEntrantBinds_Top "
s (SingleEntryBinds Bool
True) = String
"SingleEntryBinds_Top "
s (UpdatableBinds Bool
True) = String
"UpdatableBinds_Top "
s (ConstructorBinds Bool
_) = String
"ConstructorBinds_Nested "
s (ReEntrantBinds Bool
_) = String
"ReEntrantBindsBinds_Nested "
s (SingleEntryBinds Bool
_) = String
"SingleEntryBinds_Nested "
s (UpdatableBinds Bool
_) = String
"UpdatableBinds_Nested "
gatherStgStats :: [StgTopBinding] -> StatEnv
gatherStgStats :: [StgTopBinding] -> StatEnv
gatherStgStats [StgTopBinding]
binds = [StatEnv] -> StatEnv
combineSEs ((StgTopBinding -> StatEnv) -> [StgTopBinding] -> [StatEnv]
forall a b. (a -> b) -> [a] -> [b]
map StgTopBinding -> StatEnv
statTopBinding [StgTopBinding]
binds)
statTopBinding :: StgTopBinding -> StatEnv
statTopBinding :: StgTopBinding -> StatEnv
statTopBinding (StgTopStringLit Id
_ ByteString
_) = CounterType -> StatEnv
countOne CounterType
Literals
statTopBinding (StgTopLifted GenStgBinding 'Vanilla
bind) = Bool -> GenStgBinding 'Vanilla -> StatEnv
statBinding Bool
True GenStgBinding 'Vanilla
bind
statBinding :: Bool
-> StgBinding
-> StatEnv
statBinding :: Bool -> GenStgBinding 'Vanilla -> StatEnv
statBinding Bool
top (StgNonRec BinderP 'Vanilla
b GenStgRhs 'Vanilla
rhs)
= Bool -> (Id, GenStgRhs 'Vanilla) -> StatEnv
statRhs Bool
top (Id
BinderP 'Vanilla
b, GenStgRhs 'Vanilla
rhs)
statBinding Bool
top (StgRec [(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
pairs)
= [StatEnv] -> StatEnv
combineSEs (((Id, GenStgRhs 'Vanilla) -> StatEnv)
-> [(Id, GenStgRhs 'Vanilla)] -> [StatEnv]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> (Id, GenStgRhs 'Vanilla) -> StatEnv
statRhs Bool
top) [(Id, GenStgRhs 'Vanilla)]
[(BinderP 'Vanilla, GenStgRhs 'Vanilla)]
pairs)
statRhs :: Bool -> (Id, StgRhs) -> StatEnv
statRhs :: Bool -> (Id, GenStgRhs 'Vanilla) -> StatEnv
statRhs Bool
top (Id
_, StgRhsCon CostCentreStack
_ DataCon
_ ConstructorNumber
_ [StgTickish]
_ [StgArg]
_)
= CounterType -> StatEnv
countOne (Bool -> CounterType
ConstructorBinds Bool
top)
statRhs Bool
top (Id
_, StgRhsClosure XRhsClosure 'Vanilla
_ CostCentreStack
_ UpdateFlag
u [BinderP 'Vanilla]
_ GenStgExpr 'Vanilla
body)
= GenStgExpr 'Vanilla -> StatEnv
statExpr GenStgExpr 'Vanilla
body StatEnv -> StatEnv -> StatEnv
`combineSE`
CounterType -> StatEnv
countOne (
case UpdateFlag
u of
UpdateFlag
ReEntrant -> Bool -> CounterType
ReEntrantBinds Bool
top
UpdateFlag
Updatable -> Bool -> CounterType
UpdatableBinds Bool
top
UpdateFlag
SingleEntry -> Bool -> CounterType
SingleEntryBinds Bool
top
)
statExpr :: StgExpr -> StatEnv
statExpr :: GenStgExpr 'Vanilla -> StatEnv
statExpr (StgApp Id
_ [StgArg]
_) = CounterType -> StatEnv
countOne CounterType
Applications
statExpr (StgLit Literal
_) = CounterType -> StatEnv
countOne CounterType
Literals
statExpr (StgConApp DataCon
_ XConApp 'Vanilla
_ [StgArg]
_ [Type]
_)= CounterType -> StatEnv
countOne CounterType
ConstructorApps
statExpr (StgOpApp StgOp
_ [StgArg]
_ Type
_) = CounterType -> StatEnv
countOne CounterType
PrimitiveApps
statExpr (StgTick StgTickish
_ GenStgExpr 'Vanilla
e) = GenStgExpr 'Vanilla -> StatEnv
statExpr GenStgExpr 'Vanilla
e
statExpr (StgLetNoEscape XLetNoEscape 'Vanilla
_ GenStgBinding 'Vanilla
binds GenStgExpr 'Vanilla
body)
= Bool -> GenStgBinding 'Vanilla -> StatEnv
statBinding Bool
False GenStgBinding 'Vanilla
binds StatEnv -> StatEnv -> StatEnv
`combineSE`
GenStgExpr 'Vanilla -> StatEnv
statExpr GenStgExpr 'Vanilla
body StatEnv -> StatEnv -> StatEnv
`combineSE`
CounterType -> StatEnv
countOne CounterType
LetNoEscapes
statExpr (StgLet XLet 'Vanilla
_ GenStgBinding 'Vanilla
binds GenStgExpr 'Vanilla
body)
= Bool -> GenStgBinding 'Vanilla -> StatEnv
statBinding Bool
False GenStgBinding 'Vanilla
binds StatEnv -> StatEnv -> StatEnv
`combineSE`
GenStgExpr 'Vanilla -> StatEnv
statExpr GenStgExpr 'Vanilla
body
statExpr (StgCase GenStgExpr 'Vanilla
expr BinderP 'Vanilla
_ AltType
_ [GenStgAlt 'Vanilla]
alts)
= GenStgExpr 'Vanilla -> StatEnv
statExpr GenStgExpr 'Vanilla
expr StatEnv -> StatEnv -> StatEnv
`combineSE`
[(AltCon, [Id], GenStgExpr 'Vanilla)] -> StatEnv
forall {a} {b}. [(a, b, GenStgExpr 'Vanilla)] -> StatEnv
stat_alts [(AltCon, [Id], GenStgExpr 'Vanilla)]
[GenStgAlt 'Vanilla]
alts StatEnv -> StatEnv -> StatEnv
`combineSE`
CounterType -> StatEnv
countOne CounterType
StgCases
where
stat_alts :: [(a, b, GenStgExpr 'Vanilla)] -> StatEnv
stat_alts [(a, b, GenStgExpr 'Vanilla)]
alts
= [StatEnv] -> StatEnv
combineSEs ((GenStgExpr 'Vanilla -> StatEnv)
-> [GenStgExpr 'Vanilla] -> [StatEnv]
forall a b. (a -> b) -> [a] -> [b]
map GenStgExpr 'Vanilla -> StatEnv
statExpr [ GenStgExpr 'Vanilla
e | (a
_,b
_,GenStgExpr 'Vanilla
e) <- [(a, b, GenStgExpr 'Vanilla)]
alts ])