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 Data.Maybe ( isNothing )
27 -----------------------------------------------------------------------------
31 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
33 usageHeader = "usage: nofib-analyse [OPTION...] <logfile1> <logfile2> ..."
37 if not (null cmdline_errors) || OptHelp `elem` flags
38 then die (concat cmdline_errors ++ usageInfo usageHeader argInfo)
41 let { html = OptHTMLOutput `elem` flags;
42 latex = OptLaTeXOutput `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 summary_spec <- case [ cols | OptColumns cols <- flags ] of
57 [] -> return (pickSummary results)
58 (cols:_) -> namedColumns (split ',' cols)
60 let summary_rows = case [ rows | OptRows rows <- flags ] of
62 rows -> Just (split ',' (last rows))
64 let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args
67 sequence_ [ checkTimes prog res | table <- results,
68 (prog,res) <- fmToList table ]
72 putStr (renderHtml (htmlPage results column_headings))
74 putStr (latexOutput results column_headings summary_spec summary_rows)
76 putStr (asciiPage results column_headings summary_spec summary_rows)
79 parse_logs :: [String] -> IO [ResultTable]
81 f <- hGetContents stdin
83 parse_logs log_files =
84 mapM (\f -> do h <- openFile f ReadMode
86 return (parse_log c)) log_files
88 -----------------------------------------------------------------------------
89 -- List of tables we're going to generate
91 data PerProgTableSpec =
92 forall a . Result a =>
94 String -- Name of the table
95 String -- Short name (for column heading)
96 String -- HTML tag for the table
97 (Results -> Maybe a) -- How to get the result
98 (Results -> Status) -- How to get the status of this result
99 (a -> Bool) -- Result within reasonable limits?
101 data PerModuleTableSpec =
102 forall a . Result a =>
104 String -- Name of the table
105 String -- HTML tag for the table
106 (Results -> FiniteMap String a) -- get the module map
107 (a -> Bool) -- Result within reasonable limits?
109 -- The various per-program aspects of execution that we can generate results for.
110 size_spec = SpecP "Binary Sizes" "Size" "binary-sizes" binary_size compile_status always_ok
111 alloc_spec = SpecP "Allocations" "Allocs" "allocations" allocs run_status always_ok
112 runtime_spec = SpecP "Run Time" "Runtime" "run-times" (mean run_time) run_status time_ok
113 muttime_spec = SpecP "Mutator Time" "MutTime" "mutator-time" (mean mut_time) run_status time_ok
114 gctime_spec = SpecP "GC Time" "GCTime" "gc-time" (mean gc_time) run_status time_ok
115 gcwork_spec = SpecP "GC Work" "GCWork" "gc-work" gc_work run_status always_ok
116 instrs_spec = SpecP "Instructions" "Instrs" "instrs" instrs run_status always_ok
117 mreads_spec = SpecP "Memory Reads" "Reads" "mem-reads" mem_reads run_status always_ok
118 mwrite_spec = SpecP "Memory Writes" "Writes" "mem-writes" mem_writes run_status always_ok
119 cmiss_spec = SpecP "Cache Misses" "Misses" "cache-misses" cache_misses run_status always_ok
134 namedColumns :: [String] -> IO [PerProgTableSpec]
135 namedColumns ss = mapM findSpec ss
137 case [ spec | spec@(SpecP _ short_name _ _ _ _) <- all_specs,
139 [] -> die ("unknown column: " ++ s)
140 (spec:_) -> return spec
142 mean :: (Results -> [Float]) -> Results -> Maybe Float
143 mean f results = go (f results)
144 where go [] = Nothing
145 go fs = Just (foldl' (+) 0 fs / fromIntegral (length fs))
147 -- Look for bogus-looking times: On Linux we occasionally get timing results
148 -- that are bizarrely low, and skew the average.
149 checkTimes :: String -> Results -> IO ()
150 checkTimes prog results = do
151 check "run time" (run_time results)
152 check "mut time" (mut_time results)
153 check "GC time" (gc_time results)
157 hPutStrLn stderr ("warning: dubious " ++ kind
158 ++ " results for " ++ prog
160 | otherwise = return ()
161 where strange t = any (\r -> time_ok r && r / t > 1.4) ts
162 -- looks for times that are >40% smaller than
166 -- These are the per-prog tables we want to generate
167 per_prog_result_tab =
168 [ size_spec, alloc_spec, runtime_spec, muttime_spec, gctime_spec,
169 gcwork_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec ]
171 -- A single summary table, giving comparison figures for a number of
172 -- aspects, each in its own column. Only works when comparing two runs.
173 normal_summary_specs =
174 [ size_spec, alloc_spec, runtime_spec ]
176 cachegrind_summary_specs =
177 [ size_spec, alloc_spec, instrs_spec, mreads_spec, mwrite_spec ]
179 -- Pick an appropriate summary table: if we're cachegrinding, then
180 -- we're probably not interested in the runtime, but we are interested
181 -- in instructions, mem reads and mem writes (and vice-versa).
182 pickSummary :: [ResultTable] -> [PerProgTableSpec]
184 | isNothing (instrs (head (eltsFM (head rs)))) = normal_summary_specs
185 | otherwise = cachegrind_summary_specs
187 per_module_result_tab =
188 [ SpecM "Module Sizes" "mod-sizes" module_size always_ok
189 , SpecM "Compile Times" "compile-time" compile_time time_ok
192 always_ok :: a -> Bool
193 always_ok = const True
195 time_ok :: Float -> Bool
196 time_ok t = t > tooquick_threshold
198 -----------------------------------------------------------------------------
199 -- HTML page generation
201 --htmlPage :: Results -> [String] -> Html
202 htmlPage results args
203 = header << thetitle << reportTitle
205 +++ h1 << reportTitle
208 +++ body (gen_tables results args)
210 gen_menu = unordList (map (prog_menu_item) per_prog_result_tab
211 ++ map (module_menu_item) per_module_result_tab)
213 prog_menu_item (SpecP name _ anc _ _ _) = anchor <! [href ('#':anc)] << name
214 module_menu_item (SpecM name anc _ _) = anchor <! [href ('#':anc)] << name
216 gen_tables results args =
217 foldr1 (+++) (map (htmlGenProgTable results args) per_prog_result_tab)
218 +++ foldr1 (+++) (map (htmlGenModTable results args) per_module_result_tab)
220 htmlGenProgTable results args (SpecP title _ anc get_result get_status result_ok)
221 = sectHeading title anc
222 +++ font <! [size "1"]
223 << mkTable (htmlShowResults results args get_result get_status result_ok)
226 htmlGenModTable results args (SpecM title anc get_result result_ok)
227 = sectHeading title anc
228 +++ font <![size "1"]
229 << mkTable (htmlShowMultiResults results args get_result result_ok)
232 sectHeading :: String -> String -> Html
233 sectHeading s nm = h2 << anchor <! [name nm] << s
239 -> (Results -> Maybe a)
240 -> (Results -> Status)
244 htmlShowResults (r:rs) ss f stat result_ok
246 </> aboves (zipWith tableRow [1..] results_per_prog)
247 </> aboves ((if nodevs then []
248 else [tableRow (-1) ("-1 s.d.", lows),
249 tableRow (-1) ("+1 s.d.", highs)])
250 ++ [tableRow (-1) ("Average", gms)])
252 -- results_per_prog :: [ (String,[BoxValue a]) ]
253 results_per_prog = map (calc_result rs f stat result_ok) (fmToList r)
255 results_per_run = transpose (map snd results_per_prog)
256 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
262 -> (Results -> FiniteMap String a)
266 htmlShowMultiResults (r:rs) ss f result_ok =
268 </> aboves (map show_results_for_prog results_per_prog_mod_run)
269 </> aboves ((if nodevs then []
270 else [td << bold << "-1 s.d."
271 <-> tableRow (-1) ("", lows),
272 td << bold << "+1 s.d."
273 <-> tableRow (-1) ("", highs)])
274 ++ [td << bold << "Average"
275 <-> tableRow (-1) ("", gms)])
278 base_results = fmToList r :: [(String,Results)]
280 -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
281 results_per_prog_mod_run = map get_results_for_prog base_results
283 -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
284 get_results_for_prog (prog,r) = (prog, map get_results_for_mod (fmToList (f r)))
286 where fms = map get_run_results rs
288 get_run_results fm = case lookupFM fm prog of
292 get_results_for_mod (id,attr) = calc_result fms Just (const Success)
295 show_results_for_prog (prog,mrs) =
296 td <! [valign "top"] << bold << prog
297 <-> (if null mrs then
298 td << "(no modules compiled)"
300 toHtml (aboves (map (tableRow 0) mrs)))
302 results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run,
304 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
306 tableRow :: Int -> (String, [BoxValue]) -> HtmlTable
307 tableRow row_no (prog, results)
308 = td <! [bgcolor left_column_color] << prog
309 <-> besides (map (\s -> td <! [align "right", clr] << showBox s)
311 where clr | row_no < 0 = bgcolor average_row_color
312 | even row_no = bgcolor even_row_color
313 | otherwise = bgcolor odd_row_color
315 left_column_color = "#d0d0ff" -- light blue
316 odd_row_color = "#d0d0ff" -- light blue
317 even_row_color = "#f0f0ff" -- v. light blue
318 average_row_color = "#ffd0d0" -- light red
321 findBest :: Result a => [BoxValue a] -> [(Bool,BoxValue a)]
322 findBest stuff@(Result base : rest)
323 = map (\a -> (a==base, a))
325 best = snd (minimumBy (\a b -> fst a < fst b) no_pcnt_stuff
327 no_pcnt_stuff = map unPcnt stuff
329 unPcnt (r@(Percentage f) : rest) = (base * f/100, r) : unPcnt rest
330 unPcnt (r@(Result a) : rest) = (a, r) : unPcnt rest
331 unPcnt (_ : rest) = unPcnt rest
335 = besides (map (\s -> (td <! [align "right", width "100"] << bold << s)) ss)
337 mkTable t = table <! [cellspacing 0, cellpadding 0, border 0] << t
340 = (td <! [align "left", width "100"] << bold << "Program")
344 = (td <! [align "left", width "100"] << bold << "Program")
345 <-> (td <! [align "left", width "100"] << bold << "Module")
348 -- Calculate a color ranging from bright blue for -100% to bright red for +100%.
350 calcColor :: Int -> String
351 calcColor p | p >= 0 = "#" ++ (showHex red 2 "0000")
352 | otherwise = "#0000" ++ (showHex blue 2 "")
353 where red = p * 255 `div` 100
354 blue = (-p) * 255 `div` 100
356 showHex 0 f s = if f > 0 then take f (repeat '0') ++ s else s
357 showHex i f s = showHex (i `div` 16) (f-1) (hexDig (i `mod` 16) : s)
359 hexDig i | i > 10 = chr (i-10 + ord 'a')
360 | otherwise = chr (i + ord '0')
362 -----------------------------------------------------------------------------
363 -- LaTeX table generation (just the summary for now)
365 latexOutput results args summary_spec summary_rows =
366 (if (length results == 2)
367 then ascii_summary_table True results summary_spec summary_rows
372 -----------------------------------------------------------------------------
373 -- ASCII page generation
375 asciiPage results args summary_spec summary_rows =
378 -- only show the summary table if we're comparing two runs
379 . (if (length results == 2)
380 then ascii_summary_table False results summary_spec summary_rows . str "\n\n"
382 . interleave "\n\n" (map (asciiGenProgTable results args) per_prog_result_tab)
384 . interleave "\n\n" (map (asciiGenModTable results args) per_module_result_tab)
387 asciiGenProgTable results args (SpecP title _ anc get_result get_status result_ok)
390 . ascii_show_results results args get_result get_status result_ok
392 asciiGenModTable results args (SpecM title anc get_result result_ok)
395 . ascii_show_multi_results results args get_result result_ok
397 ascii_header width ss
398 = str "\n-------------------------------------------------------------------------------\n"
399 . str (rjustify 15 "Program")
401 . foldr (.) id (map (str . rjustify width) ss)
402 . str "\n-------------------------------------------------------------------------------\n"
408 -> (Results -> Maybe a)
409 -> (Results -> Status)
413 ascii_show_results (r:rs) ss f stat result_ok
414 = ascii_header fIELD_WIDTH ss
415 . interleave "\n" (map show_per_prog_results results_per_prog)
418 . show_per_prog_results ("-1 s.d.",lows)
420 . show_per_prog_results ("+1 s.d.",highs)
422 . show_per_prog_results ("Average",gms)
424 -- results_per_prog :: [ (String,[BoxValue a]) ]
425 results_per_prog = map (calc_result rs f stat result_ok) (fmToList r)
427 results_per_run = transpose (map snd results_per_prog)
428 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
430 -- A summary table, useful only when we are comparing two runs. This table
431 -- shows a number of different result categories, one per column.
433 :: Bool -- generate a LaTeX table?
435 -> [PerProgTableSpec]
438 ascii_summary_table latex (r1:r2:_) specs mb_restrict
439 | latex = makeLatexTable (rows ++ TableLine : av_rows)
441 makeTable (table_layout (length specs) width)
442 (TableLine : TableRow header : TableLine : rows ++ TableLine : av_rows)
444 header = BoxString "Program" : map BoxString headings
446 (headings, columns, av_cols) = unzip3 (map calc_col specs)
447 av_heads = [BoxString "Min", BoxString "Max", BoxString "Geometric Mean"]
448 baseline = fmToList r1
449 progs = map BoxString (keysFM r1)
450 rows0 = map TableRow (zipWith (:) progs (transpose columns))
452 rows1 = restrictRows mb_restrict rows0
454 rows | latex = mungeForLaTeX rows1
457 av_rows = map TableRow (zipWith (:) av_heads (transpose av_cols))
460 calc_col (SpecP _ heading _ getr gets ok)
461 = (heading, column, [min,max,mean]) -- throw away the baseline result
462 where (_, boxes) = unzip (map calc_one_result baseline)
463 calc_one_result = calc_result [r2] getr gets ok
464 column = map (\(_:b:_) -> b) boxes
465 (_,mean,_) = calc_gmsd column
466 (min,max) = calc_minmax column
468 restrictRows :: Maybe [String] -> [TableRow] -> [TableRow]
469 restrictRows Nothing rows = rows
470 restrictRows (Just these) rows = filter keep_it rows
471 where keep_it (TableRow (BoxString s: _)) = s `elem` these
472 keep_it TableLine = True
475 mungeForLaTeX :: [TableRow] -> [TableRow]
476 mungeForLaTeX = map transrow
478 transrow (TableRow boxes) = TableRow (map transbox boxes)
481 transbox (BoxString s) = BoxString (foldr transchar "" s)
484 transchar '_' s = '\\':'_':s
487 table_layout n width =
488 (str . rjustify 15) :
489 (\s -> str (space 5) . str (rjustify width s)) :
490 replicate (n-1) (str . rjustify width)
492 ascii_show_multi_results
496 -> (Results -> FiniteMap String a)
500 ascii_show_multi_results (r:rs) ss f result_ok
501 = ascii_header fIELD_WIDTH ss
502 . interleave "\n" (map show_results_for_prog results_per_prog_mod_run)
506 . show_per_prog_results ("-1 s.d.",lows)
508 . show_per_prog_results ("+1 s.d.",highs)
510 . show_per_prog_results ("Average",gms)
512 base_results = fmToList r :: [(String,Results)]
514 -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
515 results_per_prog_mod_run = map get_results_for_prog base_results
517 -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
518 get_results_for_prog (prog,r) = (prog, map get_results_for_mod (fmToList (f r)))
520 where fms = map get_run_results rs
522 get_run_results fm = case lookupFM fm prog of
526 get_results_for_mod (id,attr) = calc_result fms Just (const Success)
529 show_results_for_prog (prog,mrs) =
530 str ("\n"++prog++"\n")
532 str "(no modules compiled)\n"
534 interleave "\n" (map show_per_prog_results mrs))
536 results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run,
538 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
541 show_per_prog_results :: (String, [BoxValue]) -> ShowS
542 show_per_prog_results = show_per_prog_results_width fIELD_WIDTH
544 show_per_prog_results_width width (prog,results)
545 = str (rjustify 15 prog)
547 . foldr (.) id (map (str . rjustify width . showBox) results)
549 -- ---------------------------------------------------------------------------
550 -- Generic stuff for results generation
552 -- calc_result is a nice exercise in higher-order programming...
555 => [FiniteMap String b] -- accumulated results
556 -> (b -> Maybe a) -- get a result from the b
557 -> (b -> Status) -- get a status from the b
558 -> (a -> Bool) -- is this result ok?
559 -> (String,b) -- the baseline result
560 -> (String,[BoxValue])
562 calc_result rts get_maybe_a get_stat result_ok (prog,base_r) =
563 (prog, (just_result baseline base_stat :
566 rts' = map (\rt -> get_stuff (lookupFM rt prog)) rts
568 get_stuff Nothing = (Nothing, NotDone)
569 get_stuff (Just r) = (get_maybe_a r, get_stat r)
573 Just base | result_ok base
574 -> map (\(r,s) -> percentage r s base) rts'
576 -> map (\(r,s) -> just_result r s) rts'
579 baseline = get_maybe_a base_r
580 base_stat = get_stat base_r
582 just_result Nothing s = RunFailed s
583 just_result (Just a) s = toBox a
585 percentage Nothing s base = RunFailed s
586 percentage (Just a) s base = Percentage
587 (convert_to_percentage base a)
588 -----------------------------------------------------------------------------
589 -- Calculating geometric means and standard deviations
592 This is done using the log method, to avoid needing really large
593 intermediate results. The formula for a geometric mean is
595 (a1 * .... * an) ^ 1/n
597 which is equivalent to
599 e ^ ( (log a1 + ... + log an) / n )
601 where log is the natural logarithm function.
603 Similarly, to compute the geometric standard deviation we compute the
604 deviation of each log, take the root-mean-square, and take the
607 e ^ sqrt( ( sqr(log a1 - lbar) + ... + sqr(log an - lbar) ) / n )
609 where lbar is the mean log,
611 (log a1 + ... + log an) / n
613 This is a *factor*: i.e., the 1 s.d. points are (gm/sdf,gm*sdf); do
614 not subtract 100 from gm before performing this calculation.
616 We therefore return a (low, mean, high) triple.
620 calc_gmsd :: [BoxValue] -> (BoxValue, BoxValue, BoxValue)
622 | null percentages = (RunFailed NotDone, RunFailed NotDone, RunFailed NotDone)
623 | otherwise = let sqr x = x * x
624 len = fromIntegral (length percentages)
625 logs = map log percentages
626 lbar = sum logs / len
627 devs = map (sqr . (lbar-)) logs
628 dbar = sum devs / len
630 sdf = exp (sqrt dbar)
632 (Percentage (gm/sdf),
636 percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]
637 -- can't do log(0.0), so exclude zeros
638 -- small values have inordinate effects so cap at -95%.
640 calc_minmax :: [BoxValue] -> (BoxValue, BoxValue)
642 | null percentages = (RunFailed NotDone, RunFailed NotDone)
643 | otherwise = (Percentage (minimum percentages),
644 Percentage (maximum percentages))
646 percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]
649 -----------------------------------------------------------------------------
652 class Num a => Result a where
653 toBox :: a -> BoxValue
654 convert_to_percentage :: a -> a -> Float
656 -- We assume an Int is a size, and print it in kilobytes.
658 instance Result Int where
659 convert_to_percentage 0 size = 100
660 convert_to_percentage base size = (fromIntegral size / fromIntegral base) * 100
664 instance Result Integer where
665 convert_to_percentage 0 size = 100
666 convert_to_percentage base size = (fromInteger size / fromInteger base) * 100
670 instance Result Float where
671 convert_to_percentage 0.0 size = 100.0
672 convert_to_percentage base size = size / base * 100
676 -- -----------------------------------------------------------------------------
679 -- The contents of a box in a table
688 showBox :: BoxValue -> String
689 showBox (RunFailed stat) = show_stat stat
690 showBox (Percentage f) = show_pcntage f
691 showBox (BoxFloat f) = showFloat' Nothing (Just 2) f
692 showBox (BoxInt n) = show (n `div` 1024) ++ "k"
693 showBox (BoxInteger n) = show (n `div` 1024) ++ "k"
694 showBox (BoxString s) = s
696 instance Show BoxValue where { show = showBox }
698 show_pcntage n = show_float_signed (n-100) ++ "%"
700 show_float_signed = showFloat False False True False False Nothing (Just 1)
702 show_stat Success = "(no result)"
703 show_stat WrongStdout = "(stdout)"
704 show_stat WrongStderr = "(stderr)"
705 show_stat (Exit x) = "exit(" ++ show x ++")"
706 show_stat OutOfHeap = "(heap)"
707 show_stat OutOfStack = "(stack)"
708 show_stat NotDone = "-----"
710 -- -----------------------------------------------------------------------------
714 = TableRow [BoxValue]
717 type Layout = [String -> ShowS]
719 makeTable :: Layout -> [TableRow] -> ShowS
720 makeTable p = interleave "\n" . map do_row
721 where do_row (TableRow boxes) = applyLayout p boxes
722 do_row TableLine = str (take 80 (repeat '-'))
724 makeLatexTable :: [TableRow] -> ShowS
725 makeLatexTable = foldr (.) id . map do_row
726 where do_row (TableRow boxes)
727 = applyLayout latexTableLayout boxes . str "\\\\\n"
731 latexTableLayout :: Layout
732 latexTableLayout = box : repeat (box . (" & "++))
733 where box s = str (foldr transchar "" s)
735 transchar '%' s = s -- leave out the percentage signs
736 transchar c s = c : s
738 applyLayout :: Layout -> [BoxValue] -> ShowS
739 applyLayout layout values =
740 foldr (.) id [ f (show val) | (val,f) <- zip values layout ]
742 -- -----------------------------------------------------------------------------
745 split :: Char -> String -> [String]
746 split c s = case rest of
748 _:rest -> chunk : split c rest
749 where (chunk, rest) = break (==c) s
753 interleave s = foldr1 (\a b -> a . str s . b)
755 fIELD_WIDTH = 16 :: Int
757 -----------------------------------------------------------------------------