1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.10 2005/06/07 10:58:31 simonmar Exp $
4 -- (c) Simon Marlow 1997-2005
5 -----------------------------------------------------------------------------
14 import Text.Html hiding ((!))
15 import qualified Text.Html as Html ((!))
17 import System.Console.GetOpt
18 import System.Exit ( exitWith, ExitCode(..) )
20 import Numeric ( showFloat, showEFloat, showSigned )
21 import Data.Maybe ( isNothing )
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 latex = OptLaTeXOutput `elem` flags;
44 ascii = OptASCIIOutput `elem` flags
48 then die "Can't produce both ASCII and HTML"
52 then die "Can't both display and hide deviations"
55 results <- parse_logs other_args
57 summary_spec <- case [ cols | OptColumns cols <- flags ] of
58 [] -> return (pickSummary results)
59 (cols:_) -> namedColumns (split ',' cols)
61 let summary_rows = case [ rows | OptRows rows <- flags ] of
63 rows -> Just (split ',' (last rows))
65 let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args
68 sequence_ [ checkTimes prog res | table <- results,
69 (prog,res) <- fmToList table ]
73 putStr (renderHtml (htmlPage results column_headings))
75 putStr (latexOutput results column_headings summary_spec summary_rows)
77 putStr (asciiPage results column_headings summary_spec summary_rows)
80 parse_logs :: [String] -> IO [ResultTable]
82 f <- hGetContents stdin
84 parse_logs log_files =
85 mapM (\f -> do h <- openFile f ReadMode
87 return (parse_log c)) log_files
89 -----------------------------------------------------------------------------
90 -- List of tables we're going to generate
92 data PerProgTableSpec =
93 forall a . Result a =>
95 String -- Name of the table
96 String -- Short name (for column heading)
97 String -- HTML tag for the table
98 (Results -> Maybe a) -- How to get the result
99 (Results -> Status) -- How to get the status of this result
100 (a -> Bool) -- Result within reasonable limits?
102 data PerModuleTableSpec =
103 forall a . Result a =>
105 String -- Name of the table
106 String -- HTML tag for the table
107 (Results -> FiniteMap String a) -- get the module map
108 (a -> Bool) -- Result within reasonable limits?
110 -- The various per-program aspects of execution that we can generate results for.
111 size_spec = SpecP "Binary Sizes" "Size" "binary-sizes" binary_size compile_status always_ok
112 alloc_spec = SpecP "Allocations" "Allocs" "allocations" allocs run_status always_ok
113 runtime_spec = SpecP "Run Time" "Runtime" "run-times" (mean run_time) run_status time_ok
114 muttime_spec = SpecP "Mutator Time" "MutTime" "mutator-time" (mean mut_time) run_status time_ok
115 gctime_spec = SpecP "GC Time" "GCTime" "gc-time" (mean gc_time) run_status time_ok
116 gcwork_spec = SpecP "GC Work" "GCWork" "gc-work" gc_work run_status always_ok
117 instrs_spec = SpecP "Instructions" "Instrs" "instrs" instrs run_status always_ok
118 mreads_spec = SpecP "Memory Reads" "Reads" "mem-reads" mem_reads run_status always_ok
119 mwrite_spec = SpecP "Memory Writes" "Writes" "mem-writes" mem_writes run_status always_ok
120 cmiss_spec = SpecP "Cache Misses" "Misses" "cache-misses" cache_misses run_status always_ok
135 namedColumns :: [String] -> IO [PerProgTableSpec]
136 namedColumns ss = mapM findSpec ss
138 case [ spec | spec@(SpecP _ short_name _ _ _ _) <- all_specs,
140 [] -> die ("unknown column: " ++ s)
141 (spec:_) -> return spec
143 mean :: (Results -> [Float]) -> Results -> Maybe Float
144 mean f results = go (f results)
145 where go [] = Nothing
146 go fs = Just (foldl' (+) 0 fs / fromIntegral (length fs))
148 -- Look for bogus-looking times: On Linux we occasionally get timing results
149 -- that are bizarrely low, and skew the average.
150 checkTimes :: String -> Results -> IO ()
151 checkTimes prog results = do
152 check "run time" (run_time results)
153 check "mut time" (mut_time results)
154 check "GC time" (gc_time results)
158 hPutStrLn stderr ("warning: dubious " ++ kind
159 ++ " results for " ++ prog
161 | otherwise = return ()
162 where strange t = any (\r -> time_ok r && r / t > 1.4) ts
163 -- looks for times that are >40% smaller than
167 -- These are the per-prog tables we want to generate
168 per_prog_result_tab =
169 [ size_spec, alloc_spec, runtime_spec, muttime_spec, gctime_spec,
170 gcwork_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec ]
172 -- A single summary table, giving comparison figures for a number of
173 -- aspects, each in its own column. Only works when comparing two runs.
174 normal_summary_specs =
175 [ size_spec, alloc_spec, runtime_spec ]
177 cachegrind_summary_specs =
178 [ size_spec, alloc_spec, instrs_spec, mreads_spec, mwrite_spec ]
180 -- Pick an appropriate summary table: if we're cachegrinding, then
181 -- we're probably not interested in the runtime, but we are interested
182 -- in instructions, mem reads and mem writes (and vice-versa).
183 pickSummary :: [ResultTable] -> [PerProgTableSpec]
185 | isNothing (instrs (head (eltsFM (head rs)))) = normal_summary_specs
186 | otherwise = cachegrind_summary_specs
188 per_module_result_tab =
189 [ SpecM "Module Sizes" "mod-sizes" module_size always_ok
190 , SpecM "Compile Times" "compile-time" compile_time time_ok
193 always_ok :: a -> Bool
194 always_ok = const True
196 time_ok :: Float -> Bool
197 time_ok t = t > tooquick_threshold
199 -----------------------------------------------------------------------------
200 -- HTML page generation
202 --htmlPage :: Results -> [String] -> Html
203 htmlPage results args
204 = header << thetitle << reportTitle
206 +++ h1 << reportTitle
209 +++ body (gen_tables results args)
211 gen_menu = unordList (map (prog_menu_item) per_prog_result_tab
212 ++ map (module_menu_item) per_module_result_tab)
214 prog_menu_item (SpecP name _ anc _ _ _) = anchor <! [href ('#':anc)] << name
215 module_menu_item (SpecM name anc _ _) = anchor <! [href ('#':anc)] << name
217 gen_tables results args =
218 foldr1 (+++) (map (htmlGenProgTable results args) per_prog_result_tab)
219 +++ foldr1 (+++) (map (htmlGenModTable results args) per_module_result_tab)
221 htmlGenProgTable results args (SpecP title _ anc get_result get_status result_ok)
222 = sectHeading title anc
223 +++ font <! [size "1"]
224 << mkTable (htmlShowResults results args get_result get_status result_ok)
227 htmlGenModTable results args (SpecM title anc get_result result_ok)
228 = sectHeading title anc
229 +++ font <![size "1"]
230 << mkTable (htmlShowMultiResults results args get_result result_ok)
233 sectHeading :: String -> String -> Html
234 sectHeading s nm = h2 << anchor <! [name nm] << s
240 -> (Results -> Maybe a)
241 -> (Results -> Status)
245 htmlShowResults (r:rs) ss f stat result_ok
247 </> aboves (zipWith tableRow [1..] results_per_prog)
248 </> aboves ((if nodevs then []
249 else [tableRow (-1) ("-1 s.d.", lows),
250 tableRow (-1) ("+1 s.d.", highs)])
251 ++ [tableRow (-1) ("Average", gms)])
253 -- results_per_prog :: [ (String,[BoxValue a]) ]
254 results_per_prog = map (calc_result rs f stat result_ok) (fmToList r)
256 results_per_run = transpose (map snd results_per_prog)
257 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
263 -> (Results -> FiniteMap String a)
267 htmlShowMultiResults (r:rs) ss f result_ok =
269 </> aboves (map show_results_for_prog results_per_prog_mod_run)
270 </> aboves ((if nodevs then []
271 else [td << bold << "-1 s.d."
272 <-> tableRow (-1) ("", lows),
273 td << bold << "+1 s.d."
274 <-> tableRow (-1) ("", highs)])
275 ++ [td << bold << "Average"
276 <-> tableRow (-1) ("", gms)])
279 base_results = fmToList r :: [(String,Results)]
281 -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
282 results_per_prog_mod_run = map get_results_for_prog base_results
284 -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
285 get_results_for_prog (prog,r) = (prog, map get_results_for_mod (fmToList (f r)))
287 where fms = map get_run_results rs
289 get_run_results fm = case lookupFM fm prog of
293 get_results_for_mod (id,attr) = calc_result fms Just (const Success)
296 show_results_for_prog (prog,mrs) =
297 td <! [valign "top"] << bold << prog
298 <-> (if null mrs then
299 td << "(no modules compiled)"
301 toHtml (aboves (map (tableRow 0) mrs)))
303 results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run,
305 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
307 tableRow :: Int -> (String, [BoxValue]) -> HtmlTable
308 tableRow row_no (prog, results)
309 = td <! [bgcolor left_column_color] << prog
310 <-> besides (map (\s -> td <! [align "right", clr] << showBox s)
312 where clr | row_no < 0 = bgcolor average_row_color
313 | even row_no = bgcolor even_row_color
314 | otherwise = bgcolor odd_row_color
316 left_column_color = "#d0d0ff" -- light blue
317 odd_row_color = "#d0d0ff" -- light blue
318 even_row_color = "#f0f0ff" -- v. light blue
319 average_row_color = "#ffd0d0" -- light red
322 findBest :: Result a => [BoxValue a] -> [(Bool,BoxValue a)]
323 findBest stuff@(Result base : rest)
324 = map (\a -> (a==base, a))
326 best = snd (minimumBy (\a b -> fst a < fst b) no_pcnt_stuff
328 no_pcnt_stuff = map unPcnt stuff
330 unPcnt (r@(Percentage f) : rest) = (base * f/100, r) : unPcnt rest
331 unPcnt (r@(Result a) : rest) = (a, r) : unPcnt rest
332 unPcnt (_ : rest) = unPcnt rest
336 = besides (map (\s -> (td <! [align "right", width "100"] << bold << s)) ss)
338 mkTable t = table <! [cellspacing 0, cellpadding 0, border 0] << t
341 = (td <! [align "left", width "100"] << bold << "Program")
345 = (td <! [align "left", width "100"] << bold << "Program")
346 <-> (td <! [align "left", width "100"] << bold << "Module")
349 -- Calculate a color ranging from bright blue for -100% to bright red for +100%.
351 calcColor :: Int -> String
352 calcColor p | p >= 0 = "#" ++ (showHex red 2 "0000")
353 | otherwise = "#0000" ++ (showHex blue 2 "")
354 where red = p * 255 `div` 100
355 blue = (-p) * 255 `div` 100
357 showHex 0 f s = if f > 0 then take f (repeat '0') ++ s else s
358 showHex i f s = showHex (i `div` 16) (f-1) (hexDig (i `mod` 16) : s)
360 hexDig i | i > 10 = chr (i-10 + ord 'a')
361 | otherwise = chr (i + ord '0')
363 -----------------------------------------------------------------------------
364 -- LaTeX table generation (just the summary for now)
366 latexOutput results args summary_spec summary_rows =
367 (if (length results == 2)
368 then ascii_summary_table True results summary_spec summary_rows
373 -----------------------------------------------------------------------------
374 -- ASCII page generation
376 asciiPage results args summary_spec summary_rows =
379 -- only show the summary table if we're comparing two runs
380 . (if (length results == 2)
381 then ascii_summary_table False results summary_spec summary_rows . str "\n\n"
383 . interleave "\n\n" (map (asciiGenProgTable results args) per_prog_result_tab)
385 . interleave "\n\n" (map (asciiGenModTable results args) per_module_result_tab)
388 asciiGenProgTable results args (SpecP title _ anc get_result get_status result_ok)
391 . ascii_show_results results args get_result get_status result_ok
393 asciiGenModTable results args (SpecM title anc get_result result_ok)
396 . ascii_show_multi_results results args get_result result_ok
398 ascii_header width ss
399 = str "\n-------------------------------------------------------------------------------\n"
400 . str (rjustify 15 "Program")
402 . foldr (.) id (map (str . rjustify width) ss)
403 . str "\n-------------------------------------------------------------------------------\n"
409 -> (Results -> Maybe a)
410 -> (Results -> Status)
414 ascii_show_results (r:rs) ss f stat result_ok
415 = ascii_header fIELD_WIDTH ss
416 . interleave "\n" (map show_per_prog_results results_per_prog)
419 . show_per_prog_results ("-1 s.d.",lows)
421 . show_per_prog_results ("+1 s.d.",highs)
423 . show_per_prog_results ("Average",gms)
425 -- results_per_prog :: [ (String,[BoxValue a]) ]
426 results_per_prog = map (calc_result rs f stat result_ok) (fmToList r)
428 results_per_run = transpose (map snd results_per_prog)
429 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
431 -- A summary table, useful only when we are comparing two runs. This table
432 -- shows a number of different result categories, one per column.
434 :: Bool -- generate a LaTeX table?
436 -> [PerProgTableSpec]
439 ascii_summary_table latex (r1:r2:_) specs mb_restrict
440 | latex = makeLatexTable (rows ++ TableLine : av_rows)
442 makeTable (table_layout (length specs) width)
443 (TableLine : TableRow header : TableLine : rows ++ TableLine : av_rows)
445 header = BoxString "Program" : map BoxString headings
447 (headings, columns, av_cols) = unzip3 (map calc_col specs)
448 av_heads = [BoxString "Min", BoxString "Max", BoxString "Geometric Mean"]
449 baseline = fmToList r1
450 progs = map BoxString (keysFM r1)
451 rows0 = map TableRow (zipWith (:) progs (transpose columns))
453 rows1 = restrictRows mb_restrict rows0
455 rows | latex = mungeForLaTeX rows1
458 av_rows = map TableRow (zipWith (:) av_heads (transpose av_cols))
461 calc_col (SpecP _ heading _ getr gets ok)
462 = (heading, column, [min,max,mean]) -- throw away the baseline result
463 where (_, boxes) = unzip (map calc_one_result baseline)
464 calc_one_result = calc_result [r2] getr gets ok
465 column = map (\(_:b:_) -> b) boxes
466 (_,mean,_) = calc_gmsd column
467 (min,max) = calc_minmax column
469 restrictRows :: Maybe [String] -> [TableRow] -> [TableRow]
470 restrictRows Nothing rows = rows
471 restrictRows (Just these) rows = filter keep_it rows
472 where keep_it (TableRow (BoxString s: _)) = s `elem` these
473 keep_it TableLine = True
476 mungeForLaTeX :: [TableRow] -> [TableRow]
477 mungeForLaTeX = map transrow
479 transrow (TableRow boxes) = TableRow (map transbox boxes)
482 transbox (BoxString s) = BoxString (foldr transchar "" s)
485 transchar '_' s = '\\':'_':s
488 table_layout n width =
489 (str . rjustify 15) :
490 (\s -> str (space 5) . str (rjustify width s)) :
491 replicate (n-1) (str . rjustify width)
493 ascii_show_multi_results
497 -> (Results -> FiniteMap String a)
501 ascii_show_multi_results (r:rs) ss f result_ok
502 = ascii_header fIELD_WIDTH ss
503 . interleave "\n" (map show_results_for_prog results_per_prog_mod_run)
507 . show_per_prog_results ("-1 s.d.",lows)
509 . show_per_prog_results ("+1 s.d.",highs)
511 . show_per_prog_results ("Average",gms)
513 base_results = fmToList r :: [(String,Results)]
515 -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
516 results_per_prog_mod_run = map get_results_for_prog base_results
518 -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
519 get_results_for_prog (prog,r) = (prog, map get_results_for_mod (fmToList (f r)))
521 where fms = map get_run_results rs
523 get_run_results fm = case lookupFM fm prog of
527 get_results_for_mod (id,attr) = calc_result fms Just (const Success)
530 show_results_for_prog (prog,mrs) =
531 str ("\n"++prog++"\n")
533 str "(no modules compiled)\n"
535 interleave "\n" (map show_per_prog_results mrs))
537 results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run,
539 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
542 show_per_prog_results :: (String, [BoxValue]) -> ShowS
543 show_per_prog_results = show_per_prog_results_width fIELD_WIDTH
545 show_per_prog_results_width width (prog,results)
546 = str (rjustify 15 prog)
548 . foldr (.) id (map (str . rjustify width . showBox) results)
550 -- ---------------------------------------------------------------------------
551 -- Generic stuff for results generation
553 -- calc_result is a nice exercise in higher-order programming...
556 => [FiniteMap String b] -- accumulated results
557 -> (b -> Maybe a) -- get a result from the b
558 -> (b -> Status) -- get a status from the b
559 -> (a -> Bool) -- is this result ok?
560 -> (String,b) -- the baseline result
561 -> (String,[BoxValue])
563 calc_result rts get_maybe_a get_stat result_ok (prog,base_r) =
564 (prog, (just_result baseline base_stat :
567 rts' = map (\rt -> get_stuff (lookupFM rt prog)) rts
569 get_stuff Nothing = (Nothing, NotDone)
570 get_stuff (Just r) = (get_maybe_a r, get_stat r)
574 Just base | result_ok base
575 -> map (\(r,s) -> percentage r s base) rts'
577 -> map (\(r,s) -> just_result r s) rts'
580 baseline = get_maybe_a base_r
581 base_stat = get_stat base_r
583 just_result Nothing s = RunFailed s
584 just_result (Just a) s = toBox a
586 percentage Nothing s base = RunFailed s
587 percentage (Just a) s base = Percentage
588 (convert_to_percentage base a)
589 -----------------------------------------------------------------------------
590 -- Calculating geometric means and standard deviations
593 This is done using the log method, to avoid needing really large
594 intermediate results. The formula for a geometric mean is
596 (a1 * .... * an) ^ 1/n
598 which is equivalent to
600 e ^ ( (log a1 + ... + log an) / n )
602 where log is the natural logarithm function.
604 Similarly, to compute the geometric standard deviation we compute the
605 deviation of each log, take the root-mean-square, and take the
608 e ^ sqrt( ( sqr(log a1 - lbar) + ... + sqr(log an - lbar) ) / n )
610 where lbar is the mean log,
612 (log a1 + ... + log an) / n
614 This is a *factor*: i.e., the 1 s.d. points are (gm/sdf,gm*sdf); do
615 not subtract 100 from gm before performing this calculation.
617 We therefore return a (low, mean, high) triple.
621 calc_gmsd :: [BoxValue] -> (BoxValue, BoxValue, BoxValue)
623 | null percentages = (RunFailed NotDone, RunFailed NotDone, RunFailed NotDone)
624 | otherwise = let sqr x = x * x
625 len = fromIntegral (length percentages)
626 logs = map log percentages
627 lbar = sum logs / len
628 devs = map (sqr . (lbar-)) logs
629 dbar = sum devs / len
631 sdf = exp (sqrt dbar)
633 (Percentage (gm/sdf),
637 percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]
638 -- can't do log(0.0), so exclude zeros
639 -- small values have inordinate effects so cap at -95%.
641 calc_minmax :: [BoxValue] -> (BoxValue, BoxValue)
643 | null percentages = (RunFailed NotDone, RunFailed NotDone)
644 | otherwise = (Percentage (minimum percentages),
645 Percentage (maximum percentages))
647 percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]
650 -----------------------------------------------------------------------------
653 class Num a => Result a where
654 toBox :: a -> BoxValue
655 convert_to_percentage :: a -> a -> Float
657 -- We assume an Int is a size, and print it in kilobytes.
659 instance Result Int where
660 convert_to_percentage 0 size = 100
661 convert_to_percentage base size = (fromIntegral size / fromIntegral base) * 100
665 instance Result Integer where
666 convert_to_percentage 0 size = 100
667 convert_to_percentage base size = (fromInteger size / fromInteger base) * 100
671 instance Result Float where
672 convert_to_percentage 0.0 size = 100.0
673 convert_to_percentage base size = size / base * 100
677 -- -----------------------------------------------------------------------------
680 -- The contents of a box in a table
689 showBox :: BoxValue -> String
690 showBox (RunFailed stat) = show_stat stat
691 showBox (Percentage f) = show_pcntage f
692 showBox (BoxFloat f) = show f
693 showBox (BoxInt n) = show (n `div` 1024) ++ "k"
694 showBox (BoxInteger n) = show (n `div` 1024) ++ "k"
695 showBox (BoxString s) = s
697 instance Show BoxValue where { show = showBox }
699 show_pcntage n = show (n-100) ++ "%"
700 --show_pcntage n = show_float_signed (n-100) ++ "%"
702 --show_float_signed = showFloat False False True False False Nothing (Just 1)
704 show_stat Success = "(no result)"
705 show_stat WrongStdout = "(stdout)"
706 show_stat WrongStderr = "(stderr)"
707 show_stat (Exit x) = "exit(" ++ show x ++")"
708 show_stat OutOfHeap = "(heap)"
709 show_stat OutOfStack = "(stack)"
710 show_stat NotDone = "-----"
712 -- -----------------------------------------------------------------------------
716 = TableRow [BoxValue]
719 type Layout = [String -> ShowS]
721 makeTable :: Layout -> [TableRow] -> ShowS
722 makeTable p = interleave "\n" . map do_row
723 where do_row (TableRow boxes) = applyLayout p boxes
724 do_row TableLine = str (take 80 (repeat '-'))
726 makeLatexTable :: [TableRow] -> ShowS
727 makeLatexTable = foldr (.) id . map do_row
728 where do_row (TableRow boxes)
729 = applyLayout latexTableLayout boxes . str "\\\\\n"
733 latexTableLayout :: Layout
734 latexTableLayout = box : repeat (box . (" & "++))
735 where box s = str (foldr transchar "" s)
737 transchar '%' s = s -- leave out the percentage signs
738 transchar c s = c : s
740 applyLayout :: Layout -> [BoxValue] -> ShowS
741 applyLayout layout values =
742 foldr (.) id [ f (show val) | (val,f) <- zip values layout ]
744 -- -----------------------------------------------------------------------------
747 split :: Char -> String -> [String]
748 split c s = case rest of
750 _:rest -> chunk : split c rest
751 where (chunk, rest) = break (==c) s
755 interleave s = foldr1 (\a b -> a . str s . b)
757 fIELD_WIDTH = 16 :: Int
759 -----------------------------------------------------------------------------