utils/hpc/HpcCombine.hs

   1 ---------------------------------------------------------
   2 -- The main program for the hpc-add tool, part of HPC.
   3 -- Andy Gill, Oct 2006
   4 ---------------------------------------------------------
   5
   6 module HpcCombine (sum_plugin,combine_plugin,map_plugin) where
   7
   8 import Trace.Hpc.Tix
   9 import Trace.Hpc.Util
  10
  11 import HpcFlags
  12
  13 import Control.Monad
  14 import qualified Data.Set as Set
  15 import qualified Data.Map as Map
  16
  17 ------------------------------------------------------------------------------
  18 sum_options :: FlagOptSeq
  19 sum_options
  20         = excludeOpt
  21         . includeOpt
  22         . outputOpt
  23         . unionModuleOpt
  24
  25 sum_plugin :: Plugin
  26 sum_plugin = Plugin { name = "sum"
  27                        , usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
  28                        , options = sum_options
  29                        , summary = "Sum multiple .tix files in a single .tix file"
  30                        , implementation = sum_main
  31                        , init_flags = default_flags
  32                        , final_flags = default_final_flags
  33                        }
  34
  35 combine_options :: FlagOptSeq
  36 combine_options
  37         = excludeOpt
  38         . includeOpt
  39         . outputOpt
  40         . combineFunOpt
  41         . combineFunOptInfo
  42         . unionModuleOpt
  43
  44 combine_plugin :: Plugin
  45 combine_plugin = Plugin { name = "combine"
  46                        , usage = "[OPTION] .. <TIX_FILE> <TIX_FILE>"
  47                        , options = combine_options
  48                        , summary = "Combine two .tix files in a single .tix file"
  49                        , implementation = combine_main
  50                        , init_flags = default_flags
  51                        , final_flags = default_final_flags
  52                        }
  53
  54 map_options :: FlagOptSeq
  55 map_options
  56         = excludeOpt
  57         . includeOpt
  58         . outputOpt
  59         . mapFunOpt
  60         . mapFunOptInfo
  61         . unionModuleOpt
  62
  63 map_plugin :: Plugin
  64 map_plugin = Plugin { name = "map"
  65                        , usage = "[OPTION] .. <TIX_FILE> "
  66                        , options = map_options
  67                        , summary = "Map a function over a single .tix file"
  68                        , implementation = map_main
  69                        , init_flags = default_flags
  70                        , final_flags = default_final_flags
  71                        }
  72
  73 ------------------------------------------------------------------------------
  74
  75 sum_main :: Flags -> [String] -> IO ()
  76 sum_main _     [] = hpcError sum_plugin $ "no .tix file specified"
  77 sum_main flags (first_file:more_files) = do
  78   Just tix <- readTix first_file
  79
  80   tix' <- foldM (mergeTixFile flags (+))
  81                 (filterTix flags tix)
  82                 more_files
  83
  84   case outputFile flags of
  85     "-" -> putStrLn (show tix')
  86     out -> writeTix out tix'
  87
  88 combine_main :: Flags -> [String] -> IO ()
  89 combine_main flags [first_file,second_file] = do
  90   let f = theCombineFun (combineFun flags)
  91
  92   Just tix1 <- readTix first_file
  93   Just tix2 <- readTix second_file
  94
  95   let tix = mergeTix (mergeModule flags)
  96                      f
  97                      (filterTix flags tix1)
  98                      (filterTix flags tix2)
  99
 100   case outputFile flags of
 101     "-" -> putStrLn (show tix)
 102     out -> writeTix out tix
 103 combine_main _     _ = hpcError combine_plugin $ "need exactly two .tix files to combine"
 104
 105 map_main :: Flags -> [String] -> IO ()
 106 map_main flags [first_file] = do
 107   let f = thePostFun (postFun flags)
 108
 109   Just tix <- readTix first_file
 110
 111   let (Tix inside_tix) = filterTix flags tix
 112   let tix' = Tix [ TixModule m p i (map f t)
 113                  | TixModule m p i t <- inside_tix
 114                  ]
 115
 116   case outputFile flags of
 117     "-" -> putStrLn (show tix')
 118     out -> writeTix out tix'
 119 map_main _     [] = hpcError map_plugin $ "no .tix file specified"
 120 map_main _     _  = hpcError map_plugin $ "to many .tix files specified"
 121
 122 mergeTixFile :: Flags -> (Integer -> Integer -> Integer) -> Tix -> String -> IO Tix
 123 mergeTixFile flags fn tix file_name = do
 124   Just new_tix <- readTix file_name
 125   return $! strict $ mergeTix (mergeModule flags) fn tix (filterTix flags new_tix)
 126
 127 -- could allow different numbering on the module info,
 128 -- as long as the total is the same; will require normalization.
 129
 130 mergeTix :: MergeFun
 131          -> (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix
 132 mergeTix modComb f
 133          (Tix t1)
 134          (Tix t2)  = Tix
 135          [ case (Map.lookup m fm1,Map.lookup m fm2) of
 136            -- todo, revisit the semantics of this combination
 137             (Just (TixModule _ hash1 len1 tix1),Just (TixModule _ hash2 len2 tix2))
 138                | hash1 /= hash2
 139                || length tix1 /= length tix2
 140                || len1 /= length tix1
 141                || len2 /= length tix2
 142                      -> error $ "mismatched in module " ++ m
 143                | otherwise      ->
 144                      TixModule m hash1 len1 (zipWith f tix1 tix2)
 145             (Just m1,Nothing) ->
 146                   m1
 147             (Nothing,Just m2) ->
 148                   m2
 149             _ -> error "impossible"
 150          | m <- Set.toList (theMergeFun modComb m1s m2s)
 151          ]
 152   where
 153    m1s = Set.fromList $ map tixModuleName t1
 154    m2s = Set.fromList $ map tixModuleName t2
 155
 156    fm1 = Map.fromList [ (tixModuleName tix,tix)
 157                       | tix <- t1
 158                       ]
 159    fm2 = Map.fromList [ (tixModuleName tix,tix)
 160                       | tix <- t2
 161                       ]
 162
 163
 164 -- What I would give for a hyperstrict :-)
 165 -- This makes things about 100 times faster.
 166 class Strict a where
 167    strict :: a -> a
 168
 169 instance Strict Integer where
 170    strict i = i
 171
 172 instance Strict Int where
 173    strict i = i
 174
 175 instance Strict Hash where      -- should be fine, because Hash is a newtype round an Int
 176    strict i = i
 177
 178 instance Strict Char where
 179    strict i = i
 180
 181 instance Strict a => Strict [a] where
 182    strict (a:as) = (((:) $! strict a) $! strict as)
 183    strict []     = []
 184
 185 instance (Strict a, Strict b) => Strict (a,b) where
 186    strict (a,b) = (((,) $! strict a) $! strict b)
 187
 188 instance Strict Tix where
 189   strict (Tix t1) =
 190             Tix $! strict t1
 191
 192 instance Strict TixModule where
 193   strict (TixModule m1 p1 i1 t1) =
 194             ((((TixModule $! strict m1) $! strict p1) $! strict i1) $! strict t1)
 195