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

{-# LANGUAGE CPP #-}

module StgStats ( showStgStats ) where

#include "HsVersions.h"

import GhcPrelude

import StgSyn

import Id (Id)
import Panic

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
/= :: 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
$cp1Ord :: Eq 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 (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 c :: CounterType
c = CounterType -> Count -> StatEnv
forall k a. k -> a -> Map k a
Map.singleton CounterType
c 1

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

showStgStats :: [StgTopBinding] -> String

showStgStats :: [StgTopBinding] -> String
showStgStats prog :: [StgTopBinding]
prog
  = "STG Statistics:\n\n"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (((CounterType, Count) -> String)
-> [(CounterType, Count)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (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 (x :: CounterType
x,n :: 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) "\n"

    s :: CounterType -> String
s Literals                = "Literals                   "
    s Applications            = "Applications               "
    s ConstructorApps         = "ConstructorApps            "
    s PrimitiveApps           = "PrimitiveApps              "
    s LetNoEscapes            = "LetNoEscapes               "
    s StgCases                = "StgCases                   "
    s FreeVariables           = "FreeVariables              "
    s (ConstructorBinds True) = "ConstructorBinds_Top       "
    s (ReEntrantBinds True)   = "ReEntrantBinds_Top         "
    s (SingleEntryBinds True) = "SingleEntryBinds_Top       "
    s (UpdatableBinds True)   = "UpdatableBinds_Top         "
    s (ConstructorBinds _)    = "ConstructorBinds_Nested    "
    s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "
    s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "
    s (UpdatableBinds _)      = "UpdatableBinds_Nested      "

gatherStgStats :: [StgTopBinding] -> StatEnv
gatherStgStats :: [StgTopBinding] -> StatEnv
gatherStgStats binds :: [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 _ _) = CounterType -> StatEnv
countOne CounterType
Literals
statTopBinding (StgTopLifted bind :: 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 top :: Bool
top (StgNonRec b :: BinderP 'Vanilla
b rhs :: GenStgRhs 'Vanilla
rhs)
  = Bool -> (Id, GenStgRhs 'Vanilla) -> StatEnv
statRhs Bool
top (Id
BinderP 'Vanilla
b, GenStgRhs 'Vanilla
rhs)

statBinding top :: Bool
top (StgRec pairs :: [(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 top :: Bool
top (_, StgRhsCon _ _ _)
  = CounterType -> StatEnv
countOne (Bool -> CounterType
ConstructorBinds Bool
top)

statRhs top :: Bool
top (_, StgRhsClosure _ _ u :: UpdateFlag
u _ body :: GenStgExpr 'Vanilla
body)
  = GenStgExpr 'Vanilla -> StatEnv
statExpr GenStgExpr 'Vanilla
body StatEnv -> StatEnv -> StatEnv
`combineSE`
    CounterType -> StatEnv
countOne (
      case UpdateFlag
u of
        ReEntrant   -> Bool -> CounterType
ReEntrantBinds   Bool
top
        Updatable   -> Bool -> CounterType
UpdatableBinds   Bool
top
        SingleEntry -> Bool -> CounterType
SingleEntryBinds Bool
top
    )

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

statExpr :: StgExpr -> StatEnv

statExpr :: GenStgExpr 'Vanilla -> StatEnv
statExpr (StgApp _ _)     = CounterType -> StatEnv
countOne CounterType
Applications
statExpr (StgLit _)       = CounterType -> StatEnv
countOne CounterType
Literals
statExpr (StgConApp _ _ _)= CounterType -> StatEnv
countOne CounterType
ConstructorApps
statExpr (StgOpApp _ _ _) = CounterType -> StatEnv
countOne CounterType
PrimitiveApps
statExpr (StgTick _ e :: GenStgExpr 'Vanilla
e)    = GenStgExpr 'Vanilla -> StatEnv
statExpr GenStgExpr 'Vanilla
e

statExpr (StgLetNoEscape _ binds :: GenStgBinding 'Vanilla
binds body :: 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 _ binds :: GenStgBinding 'Vanilla
binds body :: 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 expr :: GenStgExpr 'Vanilla
expr _ _ alts :: [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 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 | (_,_,e :: GenStgExpr 'Vanilla
e) <- [(a, b, GenStgExpr 'Vanilla)]
alts ])

statExpr (StgLam {}) = String -> StatEnv
forall a. String -> a
panic "statExpr StgLam"