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 (combine_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 combine_options
  20         = excludeOpt
  21         . includeOpt
  22         . outputOpt
  23         . combineFunOpt
  24         . combineFunOptInfo
  25         . postInvertOpt
  26
  27 combine_plugin = Plugin { name = "combine"
  28                        , usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
  29                        , options = combine_options
  30                        , summary = "Combine multiple .tix files in a single .tix files"
  31                        , implementation = combine_main
  32                        , init_flags = default_flags
  33                        , final_flags = default_final_flags
  34                        }
  35
  36 ------------------------------------------------------------------------------
  37
  38 combine_main :: Flags -> [String] -> IO ()
  39 combine_main flags (first_file:more_files) = do
  40   -- combine does not expand out the .tix filenames (by design).
  41
  42   let f = case combineFun flags of
  43             ADD  -> \ l r -> l + r
  44             SUB  -> \ l r -> max 0 (l - r)
  45             DIFF -> \ g b -> if g > 0 then 0 else min 1 b
  46             ZERO -> \ _ _ -> 0
  47
  48   Just tix <- readTix first_file
  49
  50   tix' <- foldM (mergeTixFile flags f)
  51                 (filterTix flags tix)
  52                 more_files
  53
  54   let (Tix inside_tix') = tix'
  55   let inv 0 = 1
  56       inv n = 0
  57   let tix'' = if postInvert flags
  58               then Tix [ TixModule m p i (map inv t)
  59                        | TixModule m p i t <- inside_tix'
  60                        ]
  61               else tix'
  62
  63   case outputFile flags of
  64     "-" -> putStrLn (show tix'')
  65     out -> writeTix out tix''
  66
  67 mergeTixFile :: Flags -> (Integer -> Integer -> Integer) -> Tix -> String -> IO Tix
  68 mergeTixFile flags fn tix file_name = do
  69   Just new_tix <- readTix file_name
  70   return $! strict $ mergeTix fn tix (filterTix flags new_tix)
  71
  72 -- could allow different numbering on the module info,
  73 -- as long as the total is the same; will require normalization.
  74
  75 mergeTix :: (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix
  76 mergeTix f
  77          (Tix t1)
  78          (Tix t2)  = Tix
  79          [ case (Map.lookup m fm1,Map.lookup m fm2) of
  80            -- todo, revisit the semantics of this combination
  81             (Just (TixModule _ hash1 len1 tix1),Just (TixModule _ hash2 len2 tix2))
  82                | hash1 /= hash2
  83                || length tix1 /= length tix2
  84                || len1 /= length tix1
  85                || len2 /= length tix2
  86                      -> error $ "mismatched in module " ++ m
  87                | otherwise      ->
  88                      TixModule m hash1 len1 (zipWith f tix1 tix2)
  89             (Just (TixModule _ hash1 len1 tix1),Nothing) ->
  90                   error $ "rogue module " ++ show m
  91             (Nothing,Just (TixModule _ hash2 len2 tix2)) ->
  92                   error $ "rogue module " ++ show m
  93             _ -> error "impossible"
  94          | m <- Set.toList (m1s `Set.intersection` m2s)
  95          ]
  96   where
  97    m1s = Set.fromList $ map tixModuleName t1
  98    m2s = Set.fromList $ map tixModuleName t2
  99
 100    fm1 = Map.fromList [ (tixModuleName tix,tix)
 101                       | tix <- t1
 102                       ]
 103    fm2 = Map.fromList [ (tixModuleName tix,tix)
 104                       | tix <- t2
 105                       ]
 106
 107
 108 -- What I would give for a hyperstrict :-)
 109 -- This makes things about 100 times faster.
 110 class Strict a where
 111    strict :: a -> a
 112
 113 instance Strict Integer where
 114    strict i = i
 115
 116 instance Strict Int where
 117    strict i = i
 118
 119 instance Strict Hash where      -- should be fine, because Hash is a newtype round an Int
 120    strict i = i
 121
 122 instance Strict Char where
 123    strict i = i
 124
 125 instance Strict a => Strict [a] where
 126    strict (a:as) = (((:) $! strict a) $! strict as)
 127    strict []     = []
 128
 129 instance (Strict a, Strict b) => Strict (a,b) where
 130    strict (a,b) = (((,) $! strict a) $! strict b)
 131
 132 instance Strict Tix where
 133   strict (Tix t1) =
 134             Tix $! strict t1
 135
 136 instance Strict TixModule where
 137   strict (TixModule m1 p1 i1 t1) =
 138             ((((TixModule $! strict m1) $! strict p1) $! strict i1) $! strict t1)
 139