d32f6196758087c20b36ca512134bc4b4256551e
[ghc.git] / compiler / main / HscStats.hs
1 -- |
2 -- Statistics for per-module compilations
3 --
4 -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
5 --
6 module HscStats ( ppSourceStats ) where
7
8 import Bag
9 import HsSyn
10 import Outputable
11 import RdrName
12 import SrcLoc
13 import Util
14
15 import Data.Char
16
17 -- | Source Statistics
18 ppSourceStats :: Bool -> Located (HsModule RdrName) -> SDoc
19 ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
20 = (if short then hcat else vcat)
21 (map pp_val
22 [("ExportAll ", export_all), -- 1 if no export list
23 ("ExportDecls ", export_ds),
24 ("ExportModules ", export_ms),
25 ("Imports ", imp_no),
26 (" ImpSafe ", imp_safe),
27 (" ImpQual ", imp_qual),
28 (" ImpAs ", imp_as),
29 (" ImpAll ", imp_all),
30 (" ImpPartial ", imp_partial),
31 (" ImpHiding ", imp_hiding),
32 ("FixityDecls ", fixity_sigs),
33 ("DefaultDecls ", default_ds),
34 ("TypeDecls ", type_ds),
35 ("DataDecls ", data_ds),
36 ("NewTypeDecls ", newt_ds),
37 ("TypeFamilyDecls ", type_fam_ds),
38 ("DataConstrs ", data_constrs),
39 ("DataDerivings ", data_derivs),
40 ("ClassDecls ", class_ds),
41 ("ClassMethods ", class_method_ds),
42 ("DefaultMethods ", default_method_ds),
43 ("InstDecls ", inst_ds),
44 ("InstMethods ", inst_method_ds),
45 ("InstType ", inst_type_ds),
46 ("InstData ", inst_data_ds),
47 ("TypeSigs ", bind_tys),
48 ("GenericSigs ", generic_sigs),
49 ("ValBinds ", val_bind_ds),
50 ("FunBinds ", fn_bind_ds),
51 ("PatSynBinds ", patsyn_ds),
52 ("InlineMeths ", method_inlines),
53 ("InlineBinds ", bind_inlines),
54 ("SpecialisedMeths ", method_specs),
55 ("SpecialisedBinds ", bind_specs)
56 ])
57 where
58 decls = map unLoc ldecls
59
60 pp_val (_, 0) = empty
61 pp_val (str, n)
62 | not short = hcat [text str, int n]
63 | otherwise = hcat [text (trim str), equals, int n, semi]
64
65 trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls)
66
67 (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs)
68 = count_sigs [d | SigD d <- decls]
69 -- NB: this omits fixity decls on local bindings and
70 -- in class decls. ToDo
71
72 tycl_decls = [d | TyClD d <- decls]
73 (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) =
74 countTyClDecls tycl_decls
75
76 inst_decls = [d | InstD d <- decls]
77 inst_ds = length inst_decls
78 default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
79 val_decls = [d | ValD d <- decls]
80
81 real_exports = case exports of { Nothing -> []; Just (L _ es) -> es }
82 n_exports = length real_exports
83 export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False})
84 real_exports
85 export_ds = n_exports - export_ms
86 export_all = case exports of { Nothing -> 1; _ -> 0 }
87
88 (val_bind_ds, fn_bind_ds, patsyn_ds)
89 = sum3 (map count_bind val_decls)
90
91 (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding)
92 = sum7 (map import_info imports)
93 (data_constrs, data_derivs)
94 = sum2 (map data_info tycl_decls)
95 (class_method_ds, default_method_ds)
96 = sum2 (map class_info tycl_decls)
97 (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)
98 = sum5 (map inst_info inst_decls)
99
100 count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0,0)
101 count_bind (PatBind {}) = (0,1,0)
102 count_bind (FunBind {}) = (0,1,0)
103 count_bind (PatSynBind {}) = (0,0,1)
104 count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)
105
106 count_sigs sigs = sum5 (map sig_info sigs)
107
108 sig_info (FixSig _) = (1,0,0,0,0)
109 sig_info (TypeSig _ _ _) = (0,1,0,0,0)
110 sig_info (SpecSig _ _ _) = (0,0,1,0,0)
111 sig_info (InlineSig _ _) = (0,0,0,1,0)
112 sig_info (GenericSig _ _) = (0,0,0,0,1)
113 sig_info _ = (0,0,0,0,0)
114
115 import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
116 , ideclAs = as, ideclHiding = spec }))
117 = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
118 safe_info = qual_info
119 qual_info False = 0
120 qual_info True = 1
121 as_info Nothing = 0
122 as_info (Just _) = 1
123 spec_info Nothing = (0,0,0,0,1,0,0)
124 spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
125 spec_info (Just (True, _)) = (0,0,0,0,0,0,1)
126
127 data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs
128 , dd_derivs = derivs}})
129 = (length cs, case derivs of Nothing -> 0
130 Just (L _ ds) -> length ds)
131 data_info _ = (0,0)
132
133 class_info decl@(ClassDecl {})
134 = (classops, addpr (sum3 (map count_bind methods)))
135 where
136 methods = map unLoc $ bagToList (tcdMeths decl)
137 (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))
138 class_info _ = (0,0)
139
140 inst_info (TyFamInstD {}) = (0,0,0,1,0)
141 inst_info (DataFamInstD {}) = (0,0,0,0,1)
142 inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths
143 , cid_sigs = inst_sigs
144 , cid_tyfam_insts = ats
145 , cid_datafam_insts = adts } })
146 = case count_sigs (map unLoc inst_sigs) of
147 (_,_,ss,is,_) ->
148 (addpr (sum3 (map count_bind methods)),
149 ss, is, length ats, length adts)
150 where
151 methods = map unLoc $ bagToList inst_meths
152
153 -- TODO: use Sum monoid
154 addpr :: (Int,Int,Int) -> Int
155 sum2 :: [(Int, Int)] -> (Int, Int)
156 sum3 :: [(Int, Int, Int)] -> (Int, Int, Int)
157 sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int)
158 sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int)
159 add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int)
160 -> (Int, Int, Int, Int, Int, Int, Int)
161
162 addpr (x,y,z) = x+y+z
163 sum2 = foldr add2 (0,0)
164 where
165 add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
166 sum3 = foldr add3 (0,0,0)
167 where
168 add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)
169 sum5 = foldr add5 (0,0,0,0,0)
170 where
171 add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
172 sum7 = foldr add7 (0,0,0,0,0,0,0)
173
174 add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)
175