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