From c8742f253f0c0b38f977530eceaaecac55578b4b Mon Sep 17 00:00:00 2001 From: "andy@galois.com" Date: Sat, 8 Sep 2007 05:16:00 +0000 Subject: [PATCH] updating hpc toolkit The hpc overlay has been ported from hpc-0.4 The new API for readMix is now used. --- utils/hpc/Hpc.hs | 6 +-- utils/hpc/HpcDraft.hs | 15 +----- utils/hpc/HpcFlags.hs | 2 +- utils/hpc/HpcLexer.hs | 9 +++- utils/hpc/HpcMap.hs | 4 +- utils/hpc/HpcMarkup.hs | 19 ++----- utils/hpc/HpcOverlay.hs | 138 ++++++++++++++++++++++++++++++++++++++++++++--- utils/hpc/HpcParser.y | 2 +- utils/hpc/HpcReport.hs | 2 +- utils/hpc/HpcShowTix.hs | 2 +- utils/hpc/HpcUtils.hs | 12 +++++ 11 files changed, 167 insertions(+), 44 deletions(-) diff --git a/utils/hpc/Hpc.hs b/utils/hpc/Hpc.hs index e22556e..524dfe5 100644 --- a/utils/hpc/Hpc.hs +++ b/utils/hpc/Hpc.hs @@ -90,7 +90,7 @@ hooks' = [ (name hook,hook) | hook <- hooks ] help_plugin = Plugin { name = "help" , usage = "[]" - , summary = "Display help for hpc or a single command." + , summary = "Display help for hpc or a single command" , options = help_options , implementation = help_main , init_flags = default_flags @@ -122,7 +122,7 @@ version_plugin = Plugin { name = "version" , final_flags = default_final_flags } -version_main _ _ = putStrLn $ "hpc tools, version 0.5-dev" +version_main _ _ = putStrLn $ "hpc tools, version 0.6" ------------------------------------------------------------------------------- \ No newline at end of file +------------------------------------------------------------------------------ diff --git a/utils/hpc/HpcDraft.hs b/utils/hpc/HpcDraft.hs index cd72753..36e7a60 100644 --- a/utils/hpc/HpcDraft.hs +++ b/utils/hpc/HpcDraft.hs @@ -59,7 +59,7 @@ makeDraft hpcflags tix = do hash = tixModuleHash tix tixs = tixModuleTixs tix - mix@(Mix filepath timestamp hash tabstop entries) <- readMixWithFlags hpcflags tix + mix@(Mix filepath timestamp hash tabstop entries) <- readMixWithFlags hpcflags (Right tix) let forest = createMixEntryDom [ (span,(box,v > 0)) @@ -71,7 +71,7 @@ makeDraft hpcflags tix = do let non_ticked = findNotTickedFromList forest - hs <- readFileFromPath filepath (srcDirs hpcflags) + hs <- readFileFromPath (hpcError draft_plugin) filepath (srcDirs hpcflags) let hsMap :: Map.Map Int String hsMap = Map.fromList (zip [1..] $ lines hs) @@ -136,14 +136,3 @@ findNotTickedFromTree (Node (pos,[]) children) = findNotTickedFromList children findNotTickedFromList :: [MixEntryDom [(BoxLabel,Bool)]] -> [PleaseTick] findNotTickedFromList = concatMap findNotTickedFromTree -readFileFromPath :: String -> [String] -> IO String -readFileFromPath filename@('/':_) _ = readFile filename -readFileFromPath filename path0 = readTheFile path0 - where - readTheFile :: [String] -> IO String - readTheFile [] = error $ "could not find " ++ show filename - ++ " in path " ++ show path0 - readTheFile (dir:dirs) = - catch (do str <- readFile (dir ++ "/" ++ filename) - return str) - (\ _ -> readTheFile dirs) diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs index 3147af8..30d4679 100644 --- a/utils/hpc/HpcFlags.hs +++ b/utils/hpc/HpcFlags.hs @@ -110,7 +110,7 @@ postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unt $ \ f -> f { funTotals = True } ------------------------------------------------------------------------------- -readMixWithFlags :: Flags -> TixModule -> IO Mix +readMixWithFlags :: Flags -> Either String TixModule -> IO Mix readMixWithFlags flags mod = readMix [ dir ++ "/" ++ hpcDir flags | dir <- srcDirs flags ] mod diff --git a/utils/hpc/HpcLexer.hs b/utils/hpc/HpcLexer.hs index 74bec5d..3d1a640 100644 --- a/utils/hpc/HpcLexer.hs +++ b/utils/hpc/HpcLexer.hs @@ -7,6 +7,7 @@ data Token | SYM Char | INT Int | STR String + | CAT String deriving (Eq,Show) initLexer :: String -> [Token] @@ -16,6 +17,7 @@ lexer :: String -> Int -> Int -> [(Int,Int,Token)] lexer (c:cs) line column | c == '\n' = lexer cs (succ line) 0 | c == '\"' = lexerSTR cs line (succ column) + | c == '[' = lexerCAT cs "" line (succ column) | c `elem` "{};-:" = (line,column,SYM c) : lexer cs line (succ column) | isSpace c = lexer cs line (succ column) @@ -35,10 +37,15 @@ lexerINT other s line column = (line,column,INT (read s)) : lexer other line co -- not technically correct for the new column count, but a good approximation. lexerSTR cs line column = case lex ('"' : cs) of - [(str,rest)] -> (line,succ column,STR str) + [(str,rest)] -> (line,succ column,STR (read str)) : lexer rest line (length (show str) + column + 1) _ -> error "bad string" +lexerCAT (c:cs) s line column + | c == ']' = (line,column,CAT s) : lexer cs line (succ column) + | otherwise = lexerCAT cs (s ++ [c]) line (succ column) +lexerCAT other s line column = error "lexer failure in CAT" + test = do t <- readFile "EXAMPLE.tc" print (initLexer t) diff --git a/utils/hpc/HpcMap.hs b/utils/hpc/HpcMap.hs index adcc489..67e09c4 100644 --- a/utils/hpc/HpcMap.hs +++ b/utils/hpc/HpcMap.hs @@ -9,7 +9,7 @@ import qualified Data.Map as Map lookup :: Ord key => key -> Map key elt -> Maybe elt fromList :: Ord key => [(key,elt)] -> Map key elt - +fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> Map k a #if __GLASGOW_HASKELL__ < 604 type Map key elt = Map.FiniteMap key elt @@ -23,5 +23,7 @@ type Map key elt = Map.Map key elt lookup = Map.lookup fromList = Map.fromList +toList = Map.toList +fromListWith = Map.fromListWith #endif diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs index 9b920c6..3be17c8 100644 --- a/utils/hpc/HpcMarkup.hs +++ b/utils/hpc/HpcMarkup.hs @@ -10,6 +10,7 @@ import Trace.Hpc.Tix import Trace.Hpc.Util import HpcFlags +import HpcUtils import System.Environment import System.Directory @@ -143,7 +144,7 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do let theHsPath = srcDirs flags let modName0 = tixModuleName tix - (Mix origFile _ mixHash tabStop mix') <- readMixWithFlags flags tix + (Mix origFile _ mixHash tabStop mix') <- readMixWithFlags flags (Right tix) let arr_tix :: Array Int Integer arr_tix = listArray (0,length (tixModuleTixs tix) - 1) @@ -206,7 +207,7 @@ genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do } -- add prefix to modName argument - content <- readFileFromPath origFile theHsPath + content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath let content' = markup tabStop info content let show' = reverse . take 5 . (++ " ") . reverse . show @@ -450,17 +451,3 @@ red = "#f20913" green = "#60de51" yellow = "yellow" ------------------------------------------------------------------------------- - -readFileFromPath :: String -> [String] -> IO String -readFileFromPath filename@('/':_) _ = readFile filename -readFileFromPath filename path0 = readTheFile path0 - where - readTheFile :: [String] -> IO String - readTheFile [] = hpcError markup_plugin - $ "could not find " ++ show filename - ++ " in path " ++ show path0 - readTheFile (dir:dirs) = - catch (do str <- readFile (dir ++ "/" ++ filename) - return str) - (\ _ -> readTheFile dirs) diff --git a/utils/hpc/HpcOverlay.hs b/utils/hpc/HpcOverlay.hs index ba229c5..0cf56e4 100644 --- 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 + + diff --git a/utils/hpc/HpcParser.y b/utils/hpc/HpcParser.y index 9920139..74893e4 100644 --- a/utils/hpc/HpcParser.y +++ b/utils/hpc/HpcParser.y @@ -31,7 +31,7 @@ import HpcLexer '}' { SYM '}' } int { INT $$ } string { STR $$ } - cat { STR $$ } + cat { CAT $$ } %% Spec :: { Spec } diff --git a/utils/hpc/HpcReport.hs b/utils/hpc/HpcReport.hs index 77d66bd..98e4181 100644 --- a/utils/hpc/HpcReport.hs +++ b/utils/hpc/HpcReport.hs @@ -152,7 +152,7 @@ single (BinBox {}) = False modInfo :: Flags -> Bool -> TixModule -> IO ModInfo modInfo hpcflags qualDecList tix@(TixModule moduleName _ _ tickCounts) = do - Mix _ _ _ _ mes <- readMixWithFlags hpcflags tix + Mix _ _ _ _ mes <- readMixWithFlags hpcflags (Right tix) return (q (accumCounts (zip (map snd mes) tickCounts) miZero)) where q mi = if qualDecList then mi{decPaths = map (moduleName:) (decPaths mi)} diff --git a/utils/hpc/HpcShowTix.hs b/utils/hpc/HpcShowTix.hs index b81f88c..0d17668 100644 --- a/utils/hpc/HpcShowTix.hs +++ b/utils/hpc/HpcShowTix.hs @@ -38,7 +38,7 @@ showtix_main flags (prog:modNames) = do Nothing -> hpcError showtix_plugin $ "could not read .tix file : " ++ prog Just (Tix tixs) -> do tixs_mixs <- sequence - [ do mix <- readMixWithFlags hpcflags1 tix + [ do mix <- readMixWithFlags hpcflags1 (Right tix) return $ (tix,mix) | tix <- tixs , allowModule hpcflags1 (tixModuleName tix) diff --git a/utils/hpc/HpcUtils.hs b/utils/hpc/HpcUtils.hs index b679a37..ed8be63 100644 --- a/utils/hpc/HpcUtils.hs +++ b/utils/hpc/HpcUtils.hs @@ -2,6 +2,7 @@ module HpcUtils where import Trace.Hpc.Util import qualified HpcMap as Map +import HpcFlags -- turns \n into ' ' -- | grab's the text behind a HpcPos; @@ -18,3 +19,14 @@ grabHpcPos hsMap span = Nothing -> error $ "bad line number : " ++ show n ) [l1..l2] + +readFileFromPath :: (String -> IO String) -> String -> [String] -> IO String +readFileFromPath err filename@('/':_) _ = readFile filename +readFileFromPath err filename path0 = readTheFile path0 + where + readTheFile [] = err $ "could not find " ++ show filename + ++ " in path " ++ show path0 + readTheFile (dir:dirs) = + catch (do str <- readFile (dir ++ "/" ++ filename) + return str) + (\ _ -> readTheFile dirs) -- 1.7.10.4