From 1267b64b521ac2099fc163e482118a72b93afa0b Mon Sep 17 00:00:00 2001 From: "andy@galois.com" Date: Sun, 14 Oct 2007 17:10:09 +0000 Subject: [PATCH] Improving the combine mode for hpc we now have Processing Coverage files: sum Sum multiple .tix files in a single .tix file combine Combine two .tix files in a single .tix file map Map a function over a single .tix file Where sum joins many .tix files, combine joins two files (with extra functionality possible), and map just applied a function to single .tix file. These changes were improvements driven by hpc use cases. END OF DESCRIPTION*** Place the long patch description above the ***END OF DESCRIPTION*** marker. The first line of this file will be the patch name. This patch contains the following changes: M ./utils/hpc/Hpc.hs -1 +3 M ./utils/hpc/HpcCombine.hs -33 +84 M ./utils/hpc/HpcFlags.hs -11 +59 --- utils/hpc/Hpc.hs | 4 +- utils/hpc/HpcCombine.hs | 117 ++++++++++++++++++++++++++++++++++------------- utils/hpc/HpcFlags.hs | 70 +++++++++++++++++++++++----- 3 files changed, 146 insertions(+), 45 deletions(-) diff --git a/utils/hpc/Hpc.hs b/utils/hpc/Hpc.hs index 524dfe5..68fe87f 100644 --- a/utils/hpc/Hpc.hs +++ b/utils/hpc/Hpc.hs @@ -28,7 +28,7 @@ helpList = help = ["help"] reporting = ["report","markup"] overlays = ["overlay","draft"] - processing = ["combine"] + processing = ["sum","combine","map"] other = [ name hook | hook <- hooks , name hook `notElem` @@ -77,7 +77,9 @@ main = do hooks = [ help_plugin , report_plugin , markup_plugin + , sum_plugin , combine_plugin + , map_plugin , showtix_plugin , overlay_plugin , draft_plugin diff --git a/utils/hpc/HpcCombine.hs b/utils/hpc/HpcCombine.hs index ea23ab9..f64dd67 100644 --- a/utils/hpc/HpcCombine.hs +++ b/utils/hpc/HpcCombine.hs @@ -3,7 +3,7 @@ -- Andy Gill, Oct 2006 --------------------------------------------------------- -module HpcCombine (combine_plugin) where +module HpcCombine (sum_plugin,combine_plugin,map_plugin) where import Trace.Hpc.Tix import Trace.Hpc.Util @@ -16,64 +16,115 @@ import qualified HpcMap as Map import System.Environment ------------------------------------------------------------------------------ +sum_options + = excludeOpt + . includeOpt + . outputOpt + . unionModuleOpt + +sum_plugin = Plugin { name = "sum" + , usage = "[OPTION] .. [ [ ..]]" + , options = sum_options + , summary = "Sum multiple .tix files in a single .tix file" + , implementation = sum_main + , init_flags = default_flags + , final_flags = default_final_flags + } + combine_options = excludeOpt . includeOpt . outputOpt . combineFunOpt . combineFunOptInfo - . postInvertOpt - + . unionModuleOpt + combine_plugin = Plugin { name = "combine" - , usage = "[OPTION] .. [ [ ..]]" + , usage = "[OPTION] .. " , options = combine_options - , summary = "Combine multiple .tix files in a single .tix files" + , summary = "Combine two .tix files in a single .tix file" , implementation = combine_main , init_flags = default_flags , final_flags = default_final_flags } ------------------------------------------------------------------------------- +map_options + = excludeOpt + . includeOpt + . outputOpt + . mapFunOpt + . mapFunOptInfo + . unionModuleOpt -combine_main :: Flags -> [String] -> IO () -combine_main flags (first_file:more_files) = do - -- combine does not expand out the .tix filenames (by design). +map_plugin = Plugin { name = "map" + , usage = "[OPTION] .. [ [ ..]]" + , options = map_options + , summary = "Map a function over a single .tix file" + , implementation = map_main + , init_flags = default_flags + , final_flags = default_final_flags + } - let f = case combineFun flags of - ADD -> \ l r -> l + r - SUB -> \ l r -> max 0 (l - r) - DIFF -> \ g b -> if g > 0 then 0 else min 1 b - ZERO -> \ _ _ -> 0 +------------------------------------------------------------------------------ +sum_main :: Flags -> [String] -> IO () +sum_main flags [] = hpcError sum_plugin $ "no .tix file specified" +sum_main flags (first_file:more_files) = do Just tix <- readTix first_file - tix' <- foldM (mergeTixFile flags f) + tix' <- foldM (mergeTixFile flags (+)) (filterTix flags tix) more_files - let (Tix inside_tix') = tix' - let inv 0 = 1 - inv n = 0 - let tix'' = if postInvert flags - then Tix [ TixModule m p i (map inv t) - | TixModule m p i t <- inside_tix' - ] - else tix' + case outputFile flags of + "-" -> putStrLn (show tix') + out -> writeTix out tix' + +combine_main :: Flags -> [String] -> IO () +combine_main flags [first_file,second_file] = do + let f = theCombineFun (combineFun flags) + + Just tix1 <- readTix first_file + Just tix2 <- readTix second_file + + let tix = mergeTix (mergeModule flags) + f + (filterTix flags tix1) + (filterTix flags tix2) + + case outputFile flags of + "-" -> putStrLn (show tix) + out -> writeTix out tix +combine_main flags [] = hpcError sum_plugin $ "need exactly two .tix files to combine" + +map_main :: Flags -> [String] -> IO () +map_main flags [first_file] = do + let f = thePostFun (postFun flags) + + Just tix <- readTix first_file + + let (Tix inside_tix) = filterTix flags tix + let tix' = Tix [ TixModule m p i (map f t) + | TixModule m p i t <- inside_tix + ] case outputFile flags of - "-" -> putStrLn (show tix'') - out -> writeTix out tix'' + "-" -> putStrLn (show tix') + out -> writeTix out tix' +map_main flags [] = hpcError sum_plugin $ "no .tix file specified" +map_main flags _ = hpcError sum_plugin $ "to many .tix files specified" mergeTixFile :: Flags -> (Integer -> Integer -> Integer) -> Tix -> String -> IO Tix mergeTixFile flags fn tix file_name = do Just new_tix <- readTix file_name - return $! strict $ mergeTix fn tix (filterTix flags new_tix) + return $! strict $ mergeTix (mergeModule flags) fn tix (filterTix flags new_tix) -- could allow different numbering on the module info, -- as long as the total is the same; will require normalization. -mergeTix :: (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix -mergeTix f +mergeTix :: MergeFun + -> (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix +mergeTix modComb f (Tix t1) (Tix t2) = Tix [ case (Map.lookup m fm1,Map.lookup m fm2) of @@ -86,12 +137,12 @@ mergeTix f -> error $ "mismatched in module " ++ m | otherwise -> TixModule m hash1 len1 (zipWith f tix1 tix2) - (Just (TixModule _ hash1 len1 tix1),Nothing) -> - error $ "rogue module " ++ show m - (Nothing,Just (TixModule _ hash2 len2 tix2)) -> - error $ "rogue module " ++ show m + (Just m1,Nothing) -> + m1 + (Nothing,Just m2) -> + m2 _ -> error "impossible" - | m <- Set.toList (m1s `Set.intersection` m2s) + | m <- Set.toList (theMergeFun modComb m1s m2s) ] where m1s = Set.fromList $ map tixModuleName t1 diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs index 30d4679..761163f 100644 --- a/utils/hpc/HpcFlags.hs +++ b/utils/hpc/HpcFlags.hs @@ -25,8 +25,9 @@ data Flags = Flags , funTotals :: Bool , altHighlight :: Bool - , combineFun :: CombineFun - , postInvert :: Bool + , combineFun :: CombineFun -- tick-wise combine + , postFun :: PostFun -- + , mergeModule :: MergeFun -- module-wise merge } default_flags = Flags @@ -45,9 +46,11 @@ default_flags = Flags , altHighlight = False , combineFun = ADD - , postInvert = False + , postFun = ID + , mergeModule = INTERSECTION } + -- We do this after reading flags, because the defaults -- depends on if specific flags we used. @@ -98,16 +101,27 @@ altHighlightOpt = noArg "highlight-covered" "highlight covered code, rather that code gaps" $ \ f -> f { altHighlight = True } -combineFunOpt = anArg "combine" +combineFunOpt = anArg "function" "combine .tix files with join function, default = ADD" "FUNCTION" $ \ a f -> case reads (map toUpper a) of [(c,"")] -> f { combineFun = c } _ -> error $ "no such combine function : " ++ a combineFunOptInfo = infoArg - $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst combineFuns) + $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst foldFuns) + +mapFunOpt = anArg "function" + "apply function to .tix files, default = ID" "FUNCTION" + $ \ a f -> case reads (map toUpper a) of + [(c,"")] -> f { postFun = c } + _ -> error $ "no such combine function : " ++ a +mapFunOptInfo = infoArg + $ "FUNCTION = " ++ foldr1 (\ a b -> a ++ " | " ++ b) (map fst postFuns) + +unionModuleOpt = noArg "union" + "use the union of the module namespace (default is intersection)" + $ \ f -> f { mergeModule = UNION } + -postInvertOpt = noArg "post-invert" "invert output; ticked becomes unticked, unticked becomes ticked" - $ \ f -> f { funTotals = True } ------------------------------------------------------------------------------- readMixWithFlags :: Flags -> Either String TixModule -> IO Mix @@ -121,6 +135,7 @@ command_usage plugin = putStrLn $ "Usage: hpc " ++ (name plugin) ++ " " ++ (usage plugin) ++ + "\n" ++ summary plugin ++ "\n" ++ if null (options plugin []) then "" else usageInfo "\n\nOptions:\n" (options plugin []) @@ -178,9 +193,42 @@ filterTix flags (Tix tixs) = ------------------------------------------------------------------------------ -- HpcCombine specifics -data CombineFun = ADD | DIFF | SUB | ZERO +data CombineFun = ADD | DIFF | SUB + deriving (Eq,Show, Read, Enum) + +theCombineFun :: CombineFun -> Integer -> Integer -> Integer +theCombineFun fn = case fn of + ADD -> \ l r -> l + r + SUB -> \ l r -> max 0 (l - r) + DIFF -> \ g b -> if g > 0 then 0 else min 1 b + +foldFuns :: [ (String,CombineFun) ] +foldFuns = [ (show comb,comb) + | comb <- [ADD .. SUB] + ] + +data PostFun = ID | INV | ZERO deriving (Eq,Show, Read, Enum) -combineFuns = [ (show comb,comb) - | comb <- [ADD .. ZERO] - ] +thePostFun :: PostFun -> Integer -> Integer +thePostFun ID x = x +thePostFun INV 0 = 1 +thePostFun INV n = 0 +thePostFun ZERO x = 0 + +postFuns = [ (show pos,pos) + | pos <- [INV .. ZERO] + ] + + +data MergeFun = INTERSECTION | UNION + deriving (Eq,Show, Read, Enum) + +theMergeFun :: (Ord a) => MergeFun -> Set.Set a -> Set.Set a -> Set.Set a +theMergeFun INTERSECTION = Set.intersection +theMergeFun UNION = Set.union + +mergeFuns = [ (show pos,pos) + | pos <- [INTERSECTION,UNION] + ] + -- 1.7.10.4