updating hpc toolkit

[ghc-hetmet.git] / utils / hpc / HpcOverlay.hs

diff --git a/utils/hpc/HpcOverlay.hs b/utils/hpc/HpcOverlay.hs
index ba229c5..0cf56e4 100644 (file)
--- a/utils/hpc/HpcOverlay.hs
+++ b/utils/hpc/HpcOverlay.hs
@@ -2,6 +2,12 @@ module HpcOverlay where
 
 import HpcFlags
 import HpcParser
+import HpcUtils
+import Trace.Hpc.Tix
+import Trace.Hpc.Mix
+import Trace.Hpc.Util
+import HpcMap as Map
+import Data.Tree
 
 overlay_options 
         = srcDirOpt
@@ -20,9 +26,129 @@ overlay_plugin = Plugin { name = "overlay"
 
 overlay_main flags [] = hpcError overlay_plugin $ "no overlay file specified" 
 overlay_main flags files = do
-  print ("HERE", files)
-  result <- hpcParser (head files)
-  print result
-  return ()
-  
-  
+  specs <- mapM hpcParser files
+  let spec@(Spec globals modules) = concatSpec specs
+
+  let modules1 = Map.fromListWith (++) [ (m,info) | (m,info) <- modules ]
+
+  mod_info <-
+     sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left mod)
+                  content <- readFileFromPath (hpcError overlay_plugin) origFile (srcDirs flags)
+                  processModule mod content mix mod_spec globals
+              | (mod,mod_spec) <- Map.toList modules1
+              ]
+
+
+  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 
+processModule modName modContents (Mix filepath timestamp hash tabstop entries) locals globals = do
+
+   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
+       plzTick pos (ExpBox _) (TickExpression _ match q g)  =
+                     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
+       plzTopTick pos _      (TickFunction fn q g)   =
+                    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
+              ]
+
+
+   let show' (span,stuff) = show (span,stuff,grabHpcPos hsMap span)
+
+   let forest = createMixEntryDom
+              [ (span,ix)
+              | ((span,_),ix) <- zip entries [0..]
+              ]
+
+
+   --    
+   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
+qualifier pos Nothing = True
+qualifier pos (Just (OnLine n)) = n == l1 && n == l2
+  where (l1,c1,l2,c2) = fromHpcPos pos
+qualifier pos (Just (AtPosition l1' c1' l2' c2')) 
+         = (l1', c1', l2', c2') == fromHpcPos pos
+
+concatSpec :: [Spec] -> Spec
+concatSpec = foldl1 $ 
+              \ (Spec pre1 body1) (Spec pre2 body2) 
+                    -> Spec (pre1 ++ pre2) (body1 ++ body2)
+
+
+
+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
+
+