Fix Trac #1718: interaction of error, unlifted tuples, and casts
[ghc-hetmet.git] / compiler / simplStg / StgStats.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[StgStats]{Gathers statistical information about programs}
5
6
7 The program gather statistics about
8 \begin{enumerate}
9 \item number of boxed cases
10 \item number of unboxed cases
11 \item number of let-no-escapes
12 \item number of non-updatable lets
13 \item number of updatable lets
14 \item number of applications
15 \item number of primitive applications
16 \item number of closures (does not include lets bound to constructors)
17 \item number of free variables in closures
18 %\item number of top-level functions
19 %\item number of top-level CAFs
20 \item number of constructors
21 \end{enumerate}
22
23 \begin{code}
24 {-# OPTIONS -w #-}
25 -- The above warning supression flag is a temporary kludge.
26 -- While working on this module you are encouraged to remove it and fix
27 -- any warnings in the module. See
28 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
29 -- for details
30
31 module StgStats ( showStgStats ) where
32
33 #include "HsVersions.h"
34
35 import StgSyn
36
37 import FiniteMap        ( emptyFM, plusFM_C, unitFM, fmToList, FiniteMap )
38 import Id (Id)
39 \end{code}
40
41 \begin{code}
42 data CounterType
43   = Literals
44   | Applications
45   | ConstructorApps
46   | PrimitiveApps
47   | LetNoEscapes
48   | StgCases
49   | FreeVariables
50   | ConstructorBinds Bool{-True<=>top-level-}
51   | ReEntrantBinds   Bool{-ditto-}
52   | SingleEntryBinds Bool{-ditto-}
53   | UpdatableBinds   Bool{-ditto-}
54   deriving (Eq, Ord)
55
56 type Count      = Int
57 type StatEnv    = FiniteMap CounterType Count
58 \end{code}
59
60 \begin{code}
61 emptySE :: StatEnv
62 emptySE = emptyFM
63
64 combineSE :: StatEnv -> StatEnv -> StatEnv
65 combineSE = plusFM_C (+)
66
67 combineSEs :: [StatEnv] -> StatEnv
68 combineSEs = foldr combineSE emptySE
69
70 countOne :: CounterType -> StatEnv
71 countOne c = unitFM c 1
72
73 countN :: CounterType -> Int -> StatEnv
74 countN = unitFM
75 \end{code}
76
77 %************************************************************************
78 %*                                                                      *
79 \subsection{Top-level list of bindings (a ``program'')}
80 %*                                                                      *
81 %************************************************************************
82
83 \begin{code}
84 showStgStats :: [StgBinding] -> String
85
86 showStgStats prog
87   = "STG Statistics:\n\n"
88     ++ concat (map showc (fmToList (gatherStgStats prog)))
89   where
90     showc (x,n) = (showString (s x) . shows n) "\n"
91
92     s Literals                = "Literals                   "
93     s Applications            = "Applications               "
94     s ConstructorApps         = "ConstructorApps            "
95     s PrimitiveApps           = "PrimitiveApps              "
96     s LetNoEscapes            = "LetNoEscapes               "
97     s StgCases                = "StgCases                   "
98     s FreeVariables           = "FreeVariables              "
99     s (ConstructorBinds True) = "ConstructorBinds_Top       "
100     s (ReEntrantBinds True)   = "ReEntrantBinds_Top         "
101     s (SingleEntryBinds True) = "SingleEntryBinds_Top       "
102     s (UpdatableBinds True)   = "UpdatableBinds_Top         "
103     s (ConstructorBinds _)    = "ConstructorBinds_Nested    "
104     s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "
105     s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "
106     s (UpdatableBinds _)      = "UpdatableBinds_Nested      "
107
108 gatherStgStats :: [StgBinding] -> StatEnv
109
110 gatherStgStats binds
111   = combineSEs (map (statBinding True{-top-level-}) binds)
112 \end{code}
113
114 %************************************************************************
115 %*                                                                      *
116 \subsection{Bindings}
117 %*                                                                      *
118 %************************************************************************
119
120 \begin{code}
121 statBinding :: Bool -- True <=> top-level; False <=> nested
122             -> StgBinding
123             -> StatEnv
124
125 statBinding top (StgNonRec b rhs)
126   = statRhs top (b, rhs)
127
128 statBinding top (StgRec pairs)
129   = combineSEs (map (statRhs top) pairs)
130
131 statRhs :: Bool -> (Id, StgRhs) -> StatEnv
132
133 statRhs top (b, StgRhsCon cc con args)
134   = countOne (ConstructorBinds top)
135
136 statRhs top (b, StgRhsClosure cc bi fv u _srt args body)
137   = statExpr body                       `combineSE`
138     countN FreeVariables (length fv)    `combineSE`
139     countOne (
140       case u of
141         ReEntrant   -> ReEntrantBinds   top
142         Updatable   -> UpdatableBinds   top
143         SingleEntry -> SingleEntryBinds top
144     )
145 \end{code}
146
147 %************************************************************************
148 %*                                                                      *
149 \subsection{Expressions}
150 %*                                                                      *
151 %************************************************************************
152
153 \begin{code}
154 statExpr :: StgExpr -> StatEnv
155
156 statExpr (StgApp _ _)     = countOne Applications
157 statExpr (StgLit _)       = countOne Literals
158 statExpr (StgConApp _ _)  = countOne ConstructorApps
159 statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
160 statExpr (StgSCC l e)     = statExpr e
161 statExpr (StgTick m n e)  = statExpr e
162
163 statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
164   = statBinding False{-not top-level-} binds    `combineSE`
165     statExpr body                               `combineSE`
166     countOne LetNoEscapes
167
168 statExpr (StgLet binds body)
169   = statBinding False{-not top-level-} binds    `combineSE`
170     statExpr body
171
172 statExpr (StgCase expr lve lva bndr srt alt_type alts)
173   = statExpr expr       `combineSE`
174     stat_alts alts      `combineSE`
175     countOne StgCases
176   where
177     stat_alts alts
178         = combineSEs (map statExpr [ e | (_,_,_,e) <- alts ])
179 \end{code}
180