← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to utils/hpc/HpcOverlay.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

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