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