3c0ac0d22e117b3d8edfa169a78a320545a890f1
[ghc.git] / utils / hpc / HpcCombine.hs
1 ---------------------------------------------------------
2 -- The main program for the hpc-add tool, part of HPC.
3 -- Andy Gill, Oct 2006
4 ---------------------------------------------------------
5
6 module HpcCombine (sum_plugin,combine_plugin,map_plugin) where
7
8 import Trace.Hpc.Tix
9 import Trace.Hpc.Util
10
11 import HpcFlags
12
13 import Control.Monad
14 import qualified HpcSet as Set
15 import qualified HpcMap as Map
16 import System.Environment
17
18 ------------------------------------------------------------------------------
19 sum_options
20 = excludeOpt
21 . includeOpt
22 . outputOpt
23 . unionModuleOpt
24
25 sum_plugin = Plugin { name = "sum"
26 , usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
27 , options = sum_options
28 , summary = "Sum multiple .tix files in a single .tix file"
29 , implementation = sum_main
30 , init_flags = default_flags
31 , final_flags = default_final_flags
32 }
33
34 combine_options
35 = excludeOpt
36 . includeOpt
37 . outputOpt
38 . combineFunOpt
39 . combineFunOptInfo
40 . unionModuleOpt
41
42 combine_plugin = Plugin { name = "combine"
43 , usage = "[OPTION] .. <TIX_FILE> <TIX_FILE>"
44 , options = combine_options
45 , summary = "Combine two .tix files in a single .tix file"
46 , implementation = combine_main
47 , init_flags = default_flags
48 , final_flags = default_final_flags
49 }
50
51 map_options
52 = excludeOpt
53 . includeOpt
54 . outputOpt
55 . mapFunOpt
56 . mapFunOptInfo
57 . unionModuleOpt
58
59 map_plugin = Plugin { name = "map"
60 , usage = "[OPTION] .. <TIX_FILE> "
61 , options = map_options
62 , summary = "Map a function over a single .tix file"
63 , implementation = map_main
64 , init_flags = default_flags
65 , final_flags = default_final_flags
66 }
67
68 ------------------------------------------------------------------------------
69
70 sum_main :: Flags -> [String] -> IO ()
71 sum_main flags [] = hpcError sum_plugin $ "no .tix file specified"
72 sum_main flags (first_file:more_files) = do
73 Just tix <- readTix first_file
74
75 tix' <- foldM (mergeTixFile flags (+))
76 (filterTix flags tix)
77 more_files
78
79 case outputFile flags of
80 "-" -> putStrLn (show tix')
81 out -> writeTix out tix'
82
83 combine_main :: Flags -> [String] -> IO ()
84 combine_main flags [first_file,second_file] = do
85 let f = theCombineFun (combineFun flags)
86
87 Just tix1 <- readTix first_file
88 Just tix2 <- readTix second_file
89
90 let tix = mergeTix (mergeModule flags)
91 f
92 (filterTix flags tix1)
93 (filterTix flags tix2)
94
95 case outputFile flags of
96 "-" -> putStrLn (show tix)
97 out -> writeTix out tix
98 combine_main flags [] = hpcError combine_plugin $ "need exactly two .tix files to combine"
99
100 map_main :: Flags -> [String] -> IO ()
101 map_main flags [first_file] = do
102 let f = thePostFun (postFun flags)
103
104 Just tix <- readTix first_file
105
106 let (Tix inside_tix) = filterTix flags tix
107 let tix' = Tix [ TixModule m p i (map f t)
108 | TixModule m p i t <- inside_tix
109 ]
110
111 case outputFile flags of
112 "-" -> putStrLn (show tix')
113 out -> writeTix out tix'
114 map_main flags [] = hpcError map_plugin $ "no .tix file specified"
115 map_main flags _ = hpcError map_plugin $ "to many .tix files specified"
116
117 mergeTixFile :: Flags -> (Integer -> Integer -> Integer) -> Tix -> String -> IO Tix
118 mergeTixFile flags fn tix file_name = do
119 Just new_tix <- readTix file_name
120 return $! strict $ mergeTix (mergeModule flags) fn tix (filterTix flags new_tix)
121
122 -- could allow different numbering on the module info,
123 -- as long as the total is the same; will require normalization.
124
125 mergeTix :: MergeFun
126 -> (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix
127 mergeTix modComb f
128 (Tix t1)
129 (Tix t2) = Tix
130 [ case (Map.lookup m fm1,Map.lookup m fm2) of
131 -- todo, revisit the semantics of this combination
132 (Just (TixModule _ hash1 len1 tix1),Just (TixModule _ hash2 len2 tix2))
133 | hash1 /= hash2
134 || length tix1 /= length tix2
135 || len1 /= length tix1
136 || len2 /= length tix2
137 -> error $ "mismatched in module " ++ m
138 | otherwise ->
139 TixModule m hash1 len1 (zipWith f tix1 tix2)
140 (Just m1,Nothing) ->
141 m1
142 (Nothing,Just m2) ->
143 m2
144 _ -> error "impossible"
145 | m <- Set.toList (theMergeFun modComb m1s m2s)
146 ]
147 where
148 m1s = Set.fromList $ map tixModuleName t1
149 m2s = Set.fromList $ map tixModuleName t2
150
151 fm1 = Map.fromList [ (tixModuleName tix,tix)
152 | tix <- t1
153 ]
154 fm2 = Map.fromList [ (tixModuleName tix,tix)
155 | tix <- t2
156 ]
157
158
159 -- What I would give for a hyperstrict :-)
160 -- This makes things about 100 times faster.
161 class Strict a where
162 strict :: a -> a
163
164 instance Strict Integer where
165 strict i = i
166
167 instance Strict Int where
168 strict i = i
169
170 instance Strict Hash where -- should be fine, because Hash is a newtype round an Int
171 strict i = i
172
173 instance Strict Char where
174 strict i = i
175
176 instance Strict a => Strict [a] where
177 strict (a:as) = (((:) $! strict a) $! strict as)
178 strict [] = []
179
180 instance (Strict a, Strict b) => Strict (a,b) where
181 strict (a,b) = (((,) $! strict a) $! strict b)
182
183 instance Strict Tix where
184 strict (Tix t1) =
185 Tix $! strict t1
186
187 instance Strict TixModule where
188 strict (TixModule m1 p1 i1 t1) =
189 ((((TixModule $! strict m1) $! strict p1) $! strict i1) $! strict t1)
190