1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.8 2002/09/18 12:36:39 simonmar Exp $
4 -- (c) Simon Marlow 1997-1999
5 -----------------------------------------------------------------------------
14 import Html hiding ((!))
15 import qualified Html ((!))
28 -----------------------------------------------------------------------------
32 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
34 usageHeader = "usage: nofib-analyse [OPTION...] <logfile1> <logfile2> ..."
38 if not (null cmdline_errors) || OptHelp `elem` flags
39 then die (concat cmdline_errors ++ usageInfo usageHeader argInfo)
42 let { html = OptHTMLOutput `elem` flags;
43 ascii = OptASCIIOutput `elem` flags
47 then die "Can't produce both ASCII and HTML"
51 then die "Can't both display and hide deviations"
54 results <- parse_logs other_args
56 let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args
59 then putStr (renderHtml (htmlPage results column_headings))
60 else putStr (asciiPage results column_headings)
63 parse_logs :: [String] -> IO [ResultTable]
65 f <- hGetContents stdin
67 parse_logs log_files =
68 mapM (\f -> do h <- openFile f ReadMode
70 return (parse_log c)) log_files
72 -----------------------------------------------------------------------------
73 -- List of tables we're going to generate
75 data PerProgTableSpec =
76 forall a . Result a =>
78 String -- Name of the table
79 String -- HTML tag for the table
80 (Results -> Maybe a) -- How to get the result
81 (Results -> Status) -- How to get the status of this result
82 (a -> Bool) -- Result within reasonable limits?
84 data PerModuleTableSpec =
85 forall a . Result a =>
87 String -- Name of the table
88 String -- HTML tag for the table
89 (Results -> FiniteMap String a) -- get the module map
90 (a -> Bool) -- Result within reasonable limits?
93 [ SpecP "Binary Sizes" "binary-sizes" binary_size compile_status always_ok
94 , SpecP "Allocations" "allocations" allocs run_status always_ok
95 , SpecP "Run Time" "run-times" run_time run_status time_ok
96 , SpecP "Mutator Time" "mutator-time" mut_time run_status time_ok
97 , SpecP "GC Time" "gc-time" gc_time run_status time_ok
98 , SpecP "GC Work" "gc-work" gc_work run_status always_ok
99 , SpecP "Instructions" "instrs" instrs run_status always_ok
100 , SpecP "Memory Reads" "mem-reads" mem_reads run_status always_ok
101 , SpecP "Memory Writes" "mem-writes" mem_writes run_status always_ok
102 , SpecP "Cache Misses" "cache-misses" cache_misses run_status always_ok
105 per_module_result_tab =
106 [ SpecM "Module Sizes" "mod-sizes" module_size always_ok
107 , SpecM "Compile Times" "compile-time" compile_time time_ok
110 always_ok :: a -> Bool
111 always_ok = const True
113 time_ok :: Float -> Bool
114 time_ok t = t > tooquick_threshold
116 -----------------------------------------------------------------------------
117 -- HTML page generation
119 --htmlPage :: Results -> [String] -> Html
120 htmlPage results args
121 = header << thetitle << reportTitle
123 +++ h1 << reportTitle
126 +++ body (gen_tables results args)
128 gen_menu = unordList (map (prog_menu_item) per_prog_result_tab
129 ++ map (module_menu_item) per_module_result_tab)
131 prog_menu_item (SpecP name anc _ _ _) = anchor <! [href ('#':anc)] << name
132 module_menu_item (SpecM name anc _ _) = anchor <! [href ('#':anc)] << name
134 gen_tables results args =
135 foldr1 (+++) (map (htmlGenProgTable results args) per_prog_result_tab)
136 +++ foldr1 (+++) (map (htmlGenModTable results args) per_module_result_tab)
138 htmlGenProgTable results args (SpecP title anc get_result get_status result_ok)
139 = sectHeading title anc
140 +++ font <! [size "1"]
141 << mkTable (htmlShowResults results args get_result get_status result_ok)
144 htmlGenModTable results args (SpecM title anc get_result result_ok)
145 = sectHeading title anc
146 +++ font <![size "1"]
147 << mkTable (htmlShowMultiResults results args get_result result_ok)
150 sectHeading :: String -> String -> Html
151 sectHeading s nm = h2 << anchor <! [name nm] << s
157 -> (Results -> Maybe a)
158 -> (Results -> Status)
162 htmlShowResults (r:rs) ss f stat result_ok
164 </> aboves (zipWith tableRow [1..] results_per_prog)
165 </> aboves ((if nodevs then []
166 else [tableRow (-1) ("-1 s.d.", lows),
167 tableRow (-1) ("+1 s.d.", highs)])
168 ++ [tableRow (-1) ("Average", gms)])
170 -- results_per_prog :: [ (String,[BoxValue a]) ]
171 results_per_prog = map (calc_result rs f stat result_ok) (fmToList r)
173 results_per_run = transpose (map snd results_per_prog)
174 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
180 -> (Results -> FiniteMap String a)
184 htmlShowMultiResults (r:rs) ss f result_ok =
186 </> aboves (map show_results_for_prog results_per_prog_mod_run)
187 </> aboves ((if nodevs then []
188 else [td << bold << "-1 s.d."
189 <-> tableRow (-1) ("", lows),
190 td << bold << "+1 s.d."
191 <-> tableRow (-1) ("", highs)])
192 ++ [td << bold << "Average"
193 <-> tableRow (-1) ("", gms)])
196 base_results = fmToList r :: [(String,Results)]
198 -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
199 results_per_prog_mod_run = map get_results_for_prog base_results
201 -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
202 get_results_for_prog (prog,r) = (prog, map get_results_for_mod (fmToList (f r)))
204 where fms = map get_run_results rs
206 get_run_results fm = case lookupFM fm prog of
210 get_results_for_mod (id,attr) = calc_result fms Just (const Success)
213 show_results_for_prog (prog,mrs) =
214 td <! [valign "top"] << bold << prog
215 <-> (if null mrs then
216 td << "(no modules compiled)"
218 toHtml (aboves (map (tableRow 0) mrs)))
220 results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run,
222 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
224 tableRow :: Result a => Int -> (String, [BoxValue a]) -> HtmlTable
225 tableRow row_no (prog, results)
226 = td <! [bgcolor left_column_color] << prog
227 <-> besides (map (\s -> td <! [align "right", clr] << show_box s)
229 where clr | row_no < 0 = bgcolor average_row_color
230 | even row_no = bgcolor even_row_color
231 | otherwise = bgcolor odd_row_color
233 left_column_color = "#d0d0ff" -- light blue
234 odd_row_color = "#d0d0ff" -- light blue
235 even_row_color = "#f0f0ff" -- v. light blue
236 average_row_color = "#ffd0d0" -- light red
239 findBest :: Result a => [BoxValue a] -> [(Bool,BoxValue a)]
240 findBest stuff@(Result base : rest)
241 = map (\a -> (a==base, a))
243 best = snd (minimumBy (\a b -> fst a < fst b) no_pcnt_stuff
245 no_pcnt_stuff = map unPcnt stuff
247 unPcnt (r@(Percentage f) : rest) = (base * f/100, r) : unPcnt rest
248 unPcnt (r@(Result a) : rest) = (a, r) : unPcnt rest
249 unPcnt (_ : rest) = unPcnt rest
253 = besides (map (\s -> (td <! [align "right", width "100"] << bold << s)) ss)
255 mkTable t = table <! [cellspacing 0, cellpadding 0, border 0] << t
258 = (td <! [align "left", width "100"] << bold << "Program")
262 = (td <! [align "left", width "100"] << bold << "Program")
263 <-> (td <! [align "left", width "100"] << bold << "Module")
266 -- Calculate a color ranging from bright blue for -100% to bright red for +100%.
268 calcColor :: Int -> String
269 calcColor p | p >= 0 = "#" ++ (showHex red 2 "0000")
270 | otherwise = "#0000" ++ (showHex blue 2 "")
271 where red = p * 255 `div` 100
272 blue = (-p) * 255 `div` 100
274 showHex 0 f s = if f > 0 then take f (repeat '0') ++ s else s
275 showHex i f s = showHex (i `div` 16) (f-1) (hexDig (i `mod` 16) : s)
277 hexDig i | i > 10 = chr (i-10 + ord 'a')
278 | otherwise = chr (i + ord '0')
280 -----------------------------------------------------------------------------
281 -- ASCII page generation
283 asciiPage results args =
286 . interleave "\n\n" (map (asciiGenProgTable results args) per_prog_result_tab)
288 . interleave "\n\n" (map (asciiGenModTable results args) per_module_result_tab)
291 asciiGenProgTable results args (SpecP title anc get_result get_status result_ok)
294 . ascii_show_results results args get_result get_status result_ok
296 asciiGenModTable results args (SpecM title anc get_result result_ok)
299 . ascii_show_multi_results results args get_result result_ok
302 = str "\n-------------------------------------------------------------------------------\n"
303 . str (rjustify 15 "Program")
305 . foldr (.) id (map (str . rjustify fIELD_WIDTH) ss)
306 . str "\n-------------------------------------------------------------------------------\n"
312 -> (Results -> Maybe a)
313 -> (Results -> Status)
317 ascii_show_results (r:rs) ss f stat result_ok
319 . interleave "\n" (map show_per_prog_results results_per_prog)
322 . show_per_prog_results ("-1 s.d.",lows)
324 . show_per_prog_results ("+1 s.d.",highs)
326 . show_per_prog_results ("Average",gms)
328 -- results_per_prog :: [ (String,[BoxValue a]) ]
329 results_per_prog = map (calc_result rs f stat result_ok) (fmToList r)
331 results_per_run = transpose (map snd results_per_prog)
332 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
334 ascii_show_multi_results
338 -> (Results -> FiniteMap String a)
342 ascii_show_multi_results (r:rs) ss f result_ok
344 . interleave "\n" (map show_results_for_prog results_per_prog_mod_run)
348 . show_per_prog_results ("-1 s.d.",lows)
350 . show_per_prog_results ("+1 s.d.",highs)
352 . show_per_prog_results ("Average",gms)
354 base_results = fmToList r :: [(String,Results)]
356 -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
357 results_per_prog_mod_run = map get_results_for_prog base_results
359 -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
360 get_results_for_prog (prog,r) = (prog, map get_results_for_mod (fmToList (f r)))
362 where fms = map get_run_results rs
364 get_run_results fm = case lookupFM fm prog of
368 get_results_for_mod (id,attr) = calc_result fms Just (const Success)
371 show_results_for_prog (prog,mrs) =
372 str ("\n"++prog++"\n")
374 str "(no modules compiled)\n"
376 interleave "\n" (map show_per_prog_results mrs))
378 results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run,
380 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
382 show_per_prog_results :: Result a => (String, [BoxValue a]) -> ShowS
383 show_per_prog_results (prog,results)
384 = str (rjustify 15 prog)
386 . foldr (.) id (map (str . rjustify fIELD_WIDTH . show_box) results)
388 -----------------------------------------------------------------------------
391 class Num a => Result a where
392 result_to_string :: a -> String
393 convert_to_percentage :: a -> a -> Float
395 -- We assume an Int is a size, and print it in kilobytes.
397 instance Result Int where
398 convert_to_percentage 0 size = 100
399 convert_to_percentage base size = (fromIntegral size / fromIntegral base) * 100
401 result_to_string n = show (n `div` 1024) ++ "k"
403 instance Result Integer where
404 convert_to_percentage 0 size = 100
405 convert_to_percentage base size = (fromInteger size / fromInteger base) * 100
407 result_to_string n = show (n `quot` 1024) ++ "k"
409 instance Result Float where
410 convert_to_percentage 0.0 size = 100.0
411 convert_to_percentage base size = size / base * 100
413 result_to_string = showFloat' Nothing (Just 2)
415 data BoxValue a = RunFailed Status | Percentage Float | Result a
417 -- calc_result is a nice exercise in higher-order programming...
420 => [FiniteMap String b] -- accumulated results
421 -> (b -> Maybe a) -- get a result from the b
422 -> (b -> Status) -- get a status from the b
423 -> (a -> Bool) -- is this result ok?
424 -> (String,b) -- the baseline result
425 -> (String,[BoxValue a])
427 calc_result rts get_maybe_a get_stat result_ok (prog,base_r) =
428 (prog, (just_result baseline base_stat :
431 rts' = map (\rt -> get_stuff (lookupFM rt prog)) rts
433 get_stuff Nothing = (Nothing, NotDone)
434 get_stuff (Just r) = (get_maybe_a r, get_stat r)
438 Just base | result_ok base
439 -> map (\(r,s) -> percentage r s base) rts'
441 -> map (\(r,s) -> just_result r s) rts'
444 baseline = get_maybe_a base_r
445 base_stat = get_stat base_r
447 just_result Nothing s = RunFailed s
448 just_result (Just a) s = Result a
450 percentage Nothing s base = RunFailed s
451 percentage (Just a) s base = Percentage
452 (convert_to_percentage base a)
453 show_box (RunFailed s) = show_stat s
454 show_box (Percentage p) = show_pcntage p
455 show_box (Result a) = result_to_string a
457 -----------------------------------------------------------------------------
458 -- Calculating geometric means and standard deviations
461 This is done using the log method, to avoid needing really large
462 intermediate results. The formula for a geometric mean is
464 (a1 * .... * an) ^ 1/n
466 which is equivalent to
468 e ^ ( (log a1 + ... + log an) / n )
470 where log is the natural logarithm function.
472 Similarly, to compute the geometric standard deviation we compute the
473 deviation of each log, take the root-mean-square, and take the
476 e ^ sqrt( ( sqr(log a1 - lbar) + ... + sqr(log an - lbar) ) / n )
478 where lbar is the mean log,
480 (log a1 + ... + log an) / n
482 This is a *factor*: i.e., the 1 s.d. points are (gm/sdf,gm*sdf); do
483 not subtract 100 from gm before performing this calculation.
485 We therefore return a (low, mean, high) triple.
489 calc_gmsd :: [BoxValue a] -> (BoxValue Float, BoxValue Float, BoxValue Float)
491 | null percentages = (RunFailed NotDone, RunFailed NotDone, RunFailed NotDone)
492 | otherwise = let sqr x = x * x
493 len = fromIntegral (length percentages)
494 logs = map log percentages
495 lbar = sum logs / len
496 devs = map (sqr . (lbar-)) logs
497 dbar = sum devs / len
499 sdf = exp (sqrt dbar)
501 (Percentage (gm/sdf),
505 percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]
506 -- can't do log(0.0), so exclude zeros
507 -- small values have inordinate effects so cap at -95%.
509 -----------------------------------------------------------------------------
510 -- Generic stuff for results generation
512 show_pcntage n = show_float_signed (n-100) ++ "%"
514 show_float_signed = showFloat False False True False False Nothing (Just 2)
516 show_stat Success = "(no result)"
517 show_stat WrongStdout = "(stdout)"
518 show_stat WrongStderr = "(stderr)"
519 show_stat (Exit x) = "exit(" ++ show x ++")"
520 show_stat OutOfHeap = "(heap)"
521 show_stat OutOfStack = "(stack)"
522 show_stat NotDone = "-----"
526 interleave s = foldr1 (\a b -> a . str s . b)
528 fIELD_WIDTH = 16 :: Int
530 -----------------------------------------------------------------------------