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