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