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