HpcOverlay.hs 4.93 KB
Newer Older
1
2
3
4
module HpcOverlay where

import HpcFlags
import HpcParser
andy@galois.com's avatar
andy@galois.com committed
5
6
7
8
9
10
import HpcUtils
import Trace.Hpc.Tix
import Trace.Hpc.Mix
import Trace.Hpc.Util
import HpcMap as Map
import Data.Tree
11

Ian Lynagh's avatar
Ian Lynagh committed
12
overlay_options :: FlagOptSeq
13
14
15
16
17
overlay_options 
        = srcDirOpt
        . hpcDirOpt
        . outputOpt

Ian Lynagh's avatar
Ian Lynagh committed
18
overlay_plugin :: Plugin
19
20
21
22
23
24
25
26
27
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
		       }

Ian Lynagh's avatar
Ian Lynagh committed
28
29
overlay_main :: Flags -> [String] -> IO ()
overlay_main _     [] = hpcError overlay_plugin $ "no overlay file specified" 
30
overlay_main flags files = do
andy@galois.com's avatar
andy@galois.com committed
31
  specs <- mapM hpcParser files
Ian Lynagh's avatar
Ian Lynagh committed
32
  let (Spec globals modules) = concatSpec specs
andy@galois.com's avatar
andy@galois.com committed
33
34
35
36

  let modules1 = Map.fromListWith (++) [ (m,info) | (m,info) <- modules ]

  mod_info <-
Ian Lynagh's avatar
Ian Lynagh committed
37
     sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left modu)
andy@galois.com's avatar
andy@galois.com committed
38
	           content <- readFileFromPath (hpcError overlay_plugin) origFile (srcDirs flags)
Ian Lynagh's avatar
Ian Lynagh committed
39
40
	           processModule modu content mix mod_spec globals
              | (modu, mod_spec) <- Map.toList modules1
andy@galois.com's avatar
andy@galois.com committed
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
              ]


  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 
Ian Lynagh's avatar
Ian Lynagh committed
57
processModule modName modContents (Mix _ _ hash _ entries) locals globals = do
andy@galois.com's avatar
andy@galois.com committed
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75

   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
Ian Lynagh's avatar
Ian Lynagh committed
76
       plzTick pos (ExpBox _) (TickExpression _ match q _)  =
andy@galois.com's avatar
andy@galois.com committed
77
78
79
80
81
82
83
84
85
                     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
Ian Lynagh's avatar
Ian Lynagh committed
86
       plzTopTick pos _      (TickFunction fn q _)   =
andy@galois.com's avatar
andy@galois.com committed
87
88
89
90
91
92
93
94
95
96
97
98
99
                    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
              ]


Ian Lynagh's avatar
Ian Lynagh committed
100
   -- let show' (srcspan,stuff) = show (srcspan,stuff,grabHpcPos hsMap span)
andy@galois.com's avatar
andy@galois.com committed
101
102

   let forest = createMixEntryDom
Ian Lynagh's avatar
Ian Lynagh committed
103
104
              [ (srcspan,ix)
              | ((srcspan,_),ix) <- zip entries [0..]
andy@galois.com's avatar
andy@galois.com committed
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
              ]


   --    
   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
Ian Lynagh's avatar
Ian Lynagh committed
136
qualifier _   Nothing = True
andy@galois.com's avatar
andy@galois.com committed
137
qualifier pos (Just (OnLine n)) = n == l1 && n == l2
Ian Lynagh's avatar
Ian Lynagh committed
138
  where (l1,_,l2,_) = fromHpcPos pos
andy@galois.com's avatar
andy@galois.com committed
139
140
141
142
qualifier pos (Just (AtPosition l1' c1' l2' c2')) 
	  = (l1', c1', l2', c2') == fromHpcPos pos

concatSpec :: [Spec] -> Spec
143
144
145
146
concatSpec = foldr 
	       (\ (Spec pre1 body1) (Spec pre2 body2) 
		     -> Spec (pre1 ++ pre2) (body1 ++ body2))
		(Spec [] [])
andy@galois.com's avatar
andy@galois.com committed
147
148
149
150
151
152
153
154
155
156
157



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