76cc76e0d7c4da33f45903829bcd821491ab36e3
[ghc.git] / utils / hpc / HpcOverlay.hs
1 module HpcOverlay where
2
3 import HpcFlags
4 import HpcParser
5 import HpcUtils
6 import Trace.Hpc.Tix
7 import Trace.Hpc.Mix
8 import Trace.Hpc.Util
9 import HpcMap as Map
10 import Data.Tree
11
12 overlay_options
13 = srcDirOpt
14 . hpcDirOpt
15 . outputOpt
16
17 overlay_plugin = Plugin { name = "overlay"
18 , usage = "[OPTION] .. <OVERLAY_FILE> [<OVERLAY_FILE> [...]]"
19 , options = overlay_options
20 , summary = "Generate a .tix file from an overlay file"
21 , implementation = overlay_main
22 , init_flags = default_flags
23 , final_flags = default_final_flags
24 }
25
26
27 overlay_main flags [] = hpcError overlay_plugin $ "no overlay file specified"
28 overlay_main flags files = do
29 specs <- mapM hpcParser files
30 let spec@(Spec globals modules) = concatSpec specs
31
32 let modules1 = Map.fromListWith (++) [ (m,info) | (m,info) <- modules ]
33
34 mod_info <-
35 sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left mod)
36 content <- readFileFromPath (hpcError overlay_plugin) origFile (srcDirs flags)
37 processModule mod content mix mod_spec globals
38 | (mod,mod_spec) <- Map.toList modules1
39 ]
40
41
42 let tix = Tix $ mod_info
43
44 case outputFile flags of
45 "-" -> putStrLn (show tix)
46 out -> writeFile out (show tix)
47
48
49 processModule :: String -- ^ module name
50 -> String -- ^ module contents
51 -> Mix -- ^ mix entry for this module
52 -> [Tick] -- ^ local ticks
53 -> [ExprTick] -- ^ global ticks
54 -> IO TixModule
55 processModule modName modContents (Mix filepath timestamp hash tabstop entries) locals globals = do
56
57 let hsMap :: Map.Map Int String
58 hsMap = Map.fromList (zip [1..] $ lines modContents)
59
60 let topLevelFunctions =
61 Map.fromListWith (++)
62 [ (nm,[pos])
63 | (pos,TopLevelBox [nm]) <- entries
64 ]
65
66 let inside :: HpcPos -> String -> Bool
67 inside pos nm =
68 case Map.lookup nm topLevelFunctions of
69 Nothing -> False
70 Just poss -> any (pos `insideHpcPos`) poss
71
72 -- TODO: rename plzTick => plzExprTick, plzTopPick => plzTick
73 let plzTick :: HpcPos -> BoxLabel -> ExprTick -> Bool
74 plzTick pos (ExpBox _) (TickExpression _ match q g) =
75 qualifier pos q
76 && case match of
77 Nothing -> True
78 Just str -> str == grabHpcPos hsMap pos
79 plzTick _ _ _ = False
80
81
82 plzTopTick :: HpcPos -> BoxLabel -> Tick -> Bool
83 plzTopTick pos label (ExprTick ignore) = plzTick pos label ignore
84 plzTopTick pos _ (TickFunction fn q g) =
85 qualifier pos q && pos `inside` fn
86 plzTopTick pos label (InsideFunction fn igs) =
87 pos `inside` fn && any (plzTopTick pos label) igs
88
89
90 let tixs = Map.fromList
91 [ (ix,
92 any (plzTick pos label) globals
93 || any (plzTopTick pos label) locals)
94 | (ix,(pos,label)) <- zip [0..] entries
95 ]
96
97
98 let show' (span,stuff) = show (span,stuff,grabHpcPos hsMap span)
99
100 let forest = createMixEntryDom
101 [ (span,ix)
102 | ((span,_),ix) <- zip entries [0..]
103 ]
104
105
106 --
107 let forest2 = addParentToList [] $ forest
108 -- putStrLn $ drawForest $ map (fmap show') $ forest2
109
110 let isDomList = Map.fromList
111 [ (ix,filter (/= ix) rng ++ dom)
112 | (_,(rng,dom)) <- concatMap flatten forest2
113 , ix <- rng
114 ]
115
116 -- We do not use laziness here, because the dominator lists
117 -- point to their equivent peers, creating loops.
118
119
120 let isTicked n =
121 case Map.lookup n tixs of
122 Just v -> v
123 Nothing -> error $ "can not find ix # " ++ show n
124
125 let tixs' = [ case Map.lookup n isDomList of
126 Just vs -> if any isTicked (n : vs) then 1 else 0
127 Nothing -> error $ "can not find ix in dom list # " ++ show n
128 | n <- [0..(length entries - 1)]
129 ]
130
131 return $ TixModule modName hash (length tixs') tixs'
132
133 qualifier :: HpcPos -> Maybe Qualifier -> Bool
134 qualifier pos Nothing = True
135 qualifier pos (Just (OnLine n)) = n == l1 && n == l2
136 where (l1,c1,l2,c2) = fromHpcPos pos
137 qualifier pos (Just (AtPosition l1' c1' l2' c2'))
138 = (l1', c1', l2', c2') == fromHpcPos pos
139
140 concatSpec :: [Spec] -> Spec
141 concatSpec = foldr
142 (\ (Spec pre1 body1) (Spec pre2 body2)
143 -> Spec (pre1 ++ pre2) (body1 ++ body2))
144 (Spec [] [])
145
146
147
148 addParentToTree :: [a] -> MixEntryDom [a] -> MixEntryDom ([a],[a])
149 addParentToTree path (Node (pos,a) children) =
150 Node (pos,(a,path)) (addParentToList (a ++ path) children)
151
152 addParentToList :: [a] -> [MixEntryDom [a]] -> [MixEntryDom ([a],[a])]
153 addParentToList path nodes = map (addParentToTree path) nodes
154
155