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