HpcCombine.hs 6.1 KB
Newer Older
1 2 3 4 5
---------------------------------------------------------
-- The main program for the hpc-add tool, part of HPC.
-- Andy Gill, Oct 2006
---------------------------------------------------------

ian@well-typed.com's avatar
ian@well-typed.com committed
6
module HpcCombine (sum_plugin,combine_plugin,map_plugin) where
7 8 9 10 11 12 13

import Trace.Hpc.Tix
import Trace.Hpc.Util

import HpcFlags

import Control.Monad
14 15
import qualified Data.Set as Set
import qualified Data.Map as Map
16 17

------------------------------------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
18
sum_options :: FlagOptSeq
ian@well-typed.com's avatar
ian@well-typed.com committed
19
sum_options
20 21 22
        = excludeOpt
        . includeOpt
        . outputOpt
ian@well-typed.com's avatar
ian@well-typed.com committed
23
        . unionModuleOpt
24
        . verbosityOpt
25

Ian Lynagh's avatar
Ian Lynagh committed
26
sum_plugin :: Plugin
27
sum_plugin = Plugin { name = "sum"
ian@well-typed.com's avatar
ian@well-typed.com committed
28 29 30 31 32 33 34
                    , usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
                    , 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
                    }
35

Ian Lynagh's avatar
Ian Lynagh committed
36
combine_options :: FlagOptSeq
ian@well-typed.com's avatar
ian@well-typed.com committed
37
combine_options
38 39 40 41 42
        = excludeOpt
        . includeOpt
        . outputOpt
        . combineFunOpt
        . combineFunOptInfo
ian@well-typed.com's avatar
ian@well-typed.com committed
43
        . unionModuleOpt
44
        . verbosityOpt
45

Ian Lynagh's avatar
Ian Lynagh committed
46
combine_plugin :: Plugin
47
combine_plugin = Plugin { name = "combine"
ian@well-typed.com's avatar
ian@well-typed.com committed
48 49 50 51 52 53 54
                        , usage = "[OPTION] .. <TIX_FILE> <TIX_FILE>"
                        , options = combine_options
                        , summary = "Combine two .tix files in a single .tix file"
                        , implementation = combine_main
                        , init_flags = default_flags
                        , final_flags = default_final_flags
                        }
55

Ian Lynagh's avatar
Ian Lynagh committed
56
map_options :: FlagOptSeq
ian@well-typed.com's avatar
ian@well-typed.com committed
57
map_options
58 59 60
        = excludeOpt
        . includeOpt
        . outputOpt
ian@well-typed.com's avatar
ian@well-typed.com committed
61
        . mapFunOpt
62
        . mapFunOptInfo
ian@well-typed.com's avatar
ian@well-typed.com committed
63
        . unionModuleOpt
64
        . verbosityOpt
65

Ian Lynagh's avatar
Ian Lynagh committed
66
map_plugin :: Plugin
67
map_plugin = Plugin { name = "map"
ian@well-typed.com's avatar
ian@well-typed.com committed
68 69 70 71 72 73 74
                    , usage = "[OPTION] .. <TIX_FILE> "
                    , options = map_options
                    , summary = "Map a function over a single .tix file"
                    , implementation = map_main
                    , init_flags = default_flags
                    , final_flags = default_final_flags
                    }
75

76
------------------------------------------------------------------------------
77

78
sum_main :: Flags -> [String] -> IO ()
ian@well-typed.com's avatar
ian@well-typed.com committed
79
sum_main _     [] = hpcError sum_plugin $ "no .tix file specified"
80
sum_main flags (first_file:more_files) = do
81 82
  Just tix <- readTix first_file

ian@well-typed.com's avatar
ian@well-typed.com committed
83 84 85
  tix' <- foldM (mergeTixFile flags (+))
                (filterTix flags tix)
                more_files
86

87 88 89 90 91 92 93 94 95 96 97
  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

ian@well-typed.com's avatar
ian@well-typed.com committed
98 99 100 101
  let tix = mergeTix (mergeModule flags)
                     f
                     (filterTix flags tix1)
                     (filterTix flags tix2)
102 103 104 105

  case outputFile flags of
    "-" -> putStrLn (show tix)
    out -> writeTix out tix
Ian Lynagh's avatar
Ian Lynagh committed
106
combine_main _     _ = hpcError combine_plugin $ "need exactly two .tix files to combine"
107 108 109 110 111 112 113 114 115

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)
ian@well-typed.com's avatar
ian@well-typed.com committed
116 117
                 | TixModule m p i t <- inside_tix
                 ]
118 119

  case outputFile flags of
120 121
    "-" -> putStrLn (show tix')
    out -> writeTix out tix'
ian@well-typed.com's avatar
ian@well-typed.com committed
122 123
map_main _     [] = hpcError map_plugin $ "no .tix file specified"
map_main _     _  = hpcError map_plugin $ "to many .tix files specified"
124 125 126 127

mergeTixFile :: Flags -> (Integer -> Integer -> Integer) -> Tix -> String -> IO Tix
mergeTixFile flags fn tix file_name = do
  Just new_tix <- readTix file_name
128
  return $! strict $ mergeTix (mergeModule flags) fn tix (filterTix flags new_tix)
129

ian@well-typed.com's avatar
ian@well-typed.com committed
130
-- could allow different numbering on the module info,
131 132
-- as long as the total is the same; will require normalization.

133
mergeTix :: MergeFun
ian@well-typed.com's avatar
ian@well-typed.com committed
134
         -> (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix
135
mergeTix modComb f
ian@well-typed.com's avatar
ian@well-typed.com committed
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
         (Tix t1)
         (Tix t2)  = Tix
         [ case (Map.lookup m fm1,Map.lookup m fm2) of
           -- todo, revisit the semantics of this combination
            (Just (TixModule _ hash1 len1 tix1),Just (TixModule _ hash2 len2 tix2))
               | hash1 /= hash2
               || length tix1 /= length tix2
               || len1 /= length tix1
               || len2 /= length tix2
                     -> error $ "mismatched in module " ++ m
               | otherwise      ->
                     TixModule m hash1 len1 (zipWith f tix1 tix2)
            (Just m1,Nothing) ->
                  m1
            (Nothing,Just m2) ->
                  m2
            _ -> error "impossible"
         | m <- Set.toList (theMergeFun modComb m1s m2s)
154
         ]
ian@well-typed.com's avatar
ian@well-typed.com committed
155 156
  where
   m1s = Set.fromList $ map tixModuleName t1
157 158
   m2s = Set.fromList $ map tixModuleName t2

ian@well-typed.com's avatar
ian@well-typed.com committed
159 160 161 162 163 164
   fm1 = Map.fromList [ (tixModuleName tix,tix)
                      | tix <- t1
                      ]
   fm2 = Map.fromList [ (tixModuleName tix,tix)
                      | tix <- t2
                      ]
165 166 167 168 169 170 171 172 173 174 175 176 177


-- What I would give for a hyperstrict :-)
-- This makes things about 100 times faster.
class Strict a where
   strict :: a -> a

instance Strict Integer where
   strict i = i

instance Strict Int where
   strict i = i

ian@well-typed.com's avatar
ian@well-typed.com committed
178
instance Strict Hash where      -- should be fine, because Hash is a newtype round an Int
179 180 181 182 183 184 185 186 187 188 189 190 191
   strict i = i

instance Strict Char where
   strict i = i

instance Strict a => Strict [a] where
   strict (a:as) = (((:) $! strict a) $! strict as)
   strict []     = []

instance (Strict a, Strict b) => Strict (a,b) where
   strict (a,b) = (((,) $! strict a) $! strict b)

instance Strict Tix where
ian@well-typed.com's avatar
ian@well-typed.com committed
192 193
  strict (Tix t1) =
            Tix $! strict t1
194 195

instance Strict TixModule where
ian@well-typed.com's avatar
ian@well-typed.com committed
196 197
  strict (TixModule m1 p1 i1 t1) =
            ((((TixModule $! strict m1) $! strict p1) $! strict i1) $! strict t1)
198