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