{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

\section[StgStats]{Gathers statistical information about programs}


The program gather statistics about
\begin{enumerate}
\item number of boxed cases
\item number of unboxed cases
\item number of let-no-escapes
\item number of non-updatable lets
\item number of updatable lets
\item number of applications
\item number of primitive applications
\item number of closures (does not include lets bound to constructors)
\item number of free variables in closures
%\item number of top-level functions
%\item number of top-level CAFs
\item number of constructors
\end{enumerate}
-}



module GHC.Stg.Stats ( showStgStats ) where

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{-True<=>top-level-}
  | ReEntrantBinds   Bool{-ditto-}
  | SingleEntryBinds Bool{-ditto-}
  | UpdatableBinds   Bool{-ditto-}
  deriving (CounterType -> CounterType -> Bool
(CounterType -> CounterType -> Bool)
-> (CounterType -> CounterType -> Bool) -> Eq CounterType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CounterType -> CounterType -> Bool
== :: CounterType -> CounterType -> Bool
$c/= :: CounterType -> CounterType -> Bool
/= :: 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
$ccompare :: CounterType -> CounterType -> Ordering
compare :: CounterType -> CounterType -> Ordering
$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
>= :: CounterType -> CounterType -> Bool
$cmax :: CounterType -> CounterType -> CounterType
max :: CounterType -> CounterType -> CounterType
$cmin :: CounterType -> CounterType -> CounterType
min :: CounterType -> CounterType -> CounterType
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 a b. (a -> b -> b) -> b -> [a] -> b
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

{-
************************************************************************
*                                                                      *
\subsection{Top-level list of bindings (a ``program'')}
*                                                                      *
************************************************************************
-}

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)

{-
************************************************************************
*                                                                      *
\subsection{Bindings}
*                                                                      *
************************************************************************
-}

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 -- True <=> top-level; False <=> nested
            -> 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]
_ Type
_)
  = CounterType -> StatEnv
countOne (Bool -> CounterType
ConstructorBinds Bool
top)

statRhs Bool
top (Id
_, StgRhsClosure XRhsClosure 'Vanilla
_ CostCentreStack
_ UpdateFlag
u [BinderP 'Vanilla]
_ GenStgExpr 'Vanilla
body Type
_)
  = 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
    )

{-
************************************************************************
*                                                                      *
\subsection{Expressions}
*                                                                      *
************************************************************************
-}

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 {})   = 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{-not top-level-} 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{-not top-level-} 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`
    [GenStgAlt 'Vanilla] -> StatEnv
stat_alts [GenStgAlt 'Vanilla]
alts      StatEnv -> StatEnv -> StatEnv
`combineSE`
    CounterType -> StatEnv
countOne CounterType
StgCases
  where
    stat_alts :: [GenStgAlt 'Vanilla] -> StatEnv
stat_alts = [StatEnv] -> StatEnv
combineSEs ([StatEnv] -> StatEnv)
-> ([GenStgAlt 'Vanilla] -> [StatEnv])
-> [GenStgAlt 'Vanilla]
-> StatEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenStgAlt 'Vanilla -> StatEnv)
-> [GenStgAlt 'Vanilla] -> [StatEnv]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GenStgExpr 'Vanilla -> StatEnv
statExpr (GenStgExpr 'Vanilla -> StatEnv)
-> (GenStgAlt 'Vanilla -> GenStgExpr 'Vanilla)
-> GenStgAlt 'Vanilla
-> StatEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenStgAlt 'Vanilla -> GenStgExpr 'Vanilla
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs)