1 ---------------------------------------------------------
2 -- The main program for the hpc-add tool, part of HPC.
4 ---------------------------------------------------------
6 module HpcCombine (combine_plugin) where
14 import qualified Data.Map as Map
15 import qualified Data.Set as Set
17 import System.Environment
19 ------------------------------------------------------------------------------
21 [ excludeOpt,includeOpt,outputOpt,combineFunOpt, combineFunOptInfo, postInvertOpt ]
23 combine_plugin = Plugin { name = "combine"
24 , usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
25 , options = combine_options
26 , summary = "Combine multiple .tix files in a single .tix files"
27 , implementation = combine_main
28 , init_flags = default_flags
29 , final_flags = default_final_flags
32 ------------------------------------------------------------------------------
34 combine_main :: Flags -> [String] -> IO ()
35 combine_main flags (first_file:more_files) = do
36 -- combine does not expand out the .tix filenames (by design).
38 let f = case combineFun flags of
40 SUB -> \ l r -> max 0 (l - r)
41 DIFF -> \ g b -> if g > 0 then 0 else min 1 b
44 Just tix <- readTix first_file
46 tix' <- foldM (mergeTixFile flags f)
50 let (Tix inside_tix') = tix'
53 let tix'' = if postInvert flags
54 then Tix [ TixModule m p i (map inv t)
55 | TixModule m p i t <- inside_tix'
59 case outputFile flags of
60 "-" -> putStrLn (show tix'')
61 out -> writeTix out tix''
63 mergeTixFile :: Flags -> (Integer -> Integer -> Integer) -> Tix -> String -> IO Tix
64 mergeTixFile flags fn tix file_name = do
65 Just new_tix <- readTix file_name
66 return $! strict $ mergeTix fn tix (filterTix flags new_tix)
68 -- could allow different numbering on the module info,
69 -- as long as the total is the same; will require normalization.
71 mergeTix :: (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix
75 [ case (Map.lookup m fm1,Map.lookup m fm2) of
76 -- todo, revisit the semantics of this combination
77 (Just (TixModule _ hash1 len1 tix1),Just (TixModule _ hash2 len2 tix2))
79 || length tix1 /= length tix2
80 || len1 /= length tix1
81 || len2 /= length tix2
82 -> error $ "mismatched in module " ++ m
84 TixModule m hash1 len1 (zipWith f tix1 tix2)
85 (Just (TixModule _ hash1 len1 tix1),Nothing) ->
86 error $ "rogue module " ++ show m
87 (Nothing,Just (TixModule _ hash2 len2 tix2)) ->
88 error $ "rogue module " ++ show m
89 _ -> error "impossible"
90 | m <- Set.toList (m1s `Set.intersection` m2s)
93 m1s = Set.fromList $ map tixModuleName t1
94 m2s = Set.fromList $ map tixModuleName t2
96 fm1 = Map.fromList [ (tixModuleName tix,tix)
99 fm2 = Map.fromList [ (tixModuleName tix,tix)
104 -- What I would give for a hyperstrict :-)
105 -- This makes things about 100 times faster.
109 instance Strict Integer where
112 instance Strict Int where
115 instance Strict Hash where -- should be fine, because Hash is a newtype round an Int
118 instance Strict Char where
121 instance Strict a => Strict [a] where
122 strict (a:as) = (((:) $! strict a) $! strict as)
125 instance (Strict a, Strict b) => Strict (a,b) where
126 strict (a,b) = (((,) $! strict a) $! strict b)
128 instance Strict Tix where
132 instance Strict TixModule where
133 strict (TixModule m1 p1 i1 t1) =
134 ((((TixModule $! strict m1) $! strict p1) $! strict i1) $! strict t1)