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