Move nofib-analyse from the GHC repo
[nofib.git] / nofib-analyse / Main.hs
1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.10 2005/06/07 10:58:31 simonmar Exp $
3
4 -- (c) Simon Marlow 1997-2005
5 -----------------------------------------------------------------------------
6
7 module Main where
8
9 import GenUtils
10 import Slurp
11 import CmdLine
12
13 import Text.Printf
14 import Text.Html hiding (cols, rows, (!))
15 import qualified Text.Html as Html ((!))
16 import qualified Data.Map as Map
17 import Data.Map (Map)
18 import System.Exit ( exitWith, ExitCode(..) )
19
20 import Control.Monad
21 import Data.Maybe ( isNothing )
22 import Data.Char
23 import System.IO
24 import Data.List
25
26 (<!) :: Text.Html.ADDATTRS a => a -> [HtmlAttr] -> a
27 (<!) = (Html.!)
28
29 -----------------------------------------------------------------------------
30 -- Top level stuff
31
32 die :: String -> IO a
33 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
34
35 data Normalise = NormalisePercent | NormaliseRatio | NormaliseNone
36
37 main :: IO ()
38 main = do
39
40 when (not (null cmdline_errors) || OptHelp `elem` flags) $
41 die (concat cmdline_errors ++ usage)
42
43 norm <- case [ n | OptNormalise n <- flags ] of
44 [] -> return NormalisePercent
45 ["percent"] -> return NormalisePercent
46 ["ratio"] -> return NormaliseRatio
47 ["none"] -> return NormaliseNone
48 _ -> die ("unrecognised value for --normalise\n" ++ usage)
49
50 let { html = OptHTMLOutput `elem` flags;
51 latex = [ t | OptLaTeXOutput t <- flags ];
52 ascii = OptASCIIOutput `elem` flags;
53 csv = [ t | OptCSV t <- flags ];
54 }
55
56 when (ascii && html) $ die "Can't produce both ASCII and HTML"
57 when (devs && nodevs) $ die "Can't both display and hide deviations"
58
59 results <- parse_logs other_args
60
61 summary_spec <- case [ cols | OptColumns cols <- flags ] of
62 [] -> return (pickSummary results)
63 (cols:_) -> namedColumns (split ',' cols)
64
65 let summary_rows = case [ rows | OptRows rows <- flags ] of
66 [] -> Nothing
67 rows -> Just (split ',' (last rows))
68
69 let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args
70
71 -- sanity check
72 sequence_ [ checkTimes prog res | result_table <- results,
73 (prog,res) <- Map.toList result_table ]
74
75 case () of
76 _ | not (null csv) ->
77 putStr (csvTable results (head csv) norm)
78 _ | html ->
79 putStr (renderHtml (htmlPage results column_headings))
80 _ | not (null latex) ->
81 putStr (latexOutput results (head latex) column_headings summary_spec summary_rows norm)
82 _ | otherwise ->
83 putStr (asciiPage results column_headings summary_spec summary_rows norm)
84
85
86 parse_logs :: [String] -> IO [ResultTable]
87 parse_logs [] = do
88 f <- hGetContents stdin
89 return [parse_log f]
90 parse_logs log_files =
91 mapM (\f -> do h <- openFile f ReadMode
92 c <- hGetContents h
93 return (parse_log c)) log_files
94
95 -----------------------------------------------------------------------------
96 -- List of tables we're going to generate
97
98 data PerProgTableSpec =
99 forall a . Result a =>
100 SpecP
101 String -- Name of the table
102 String -- Short name (for column heading)
103 String -- HTML tag for the table
104 (Results -> Maybe a) -- How to get the result
105 (Results -> Status) -- How to get the status of this result
106 (a -> Bool) -- Result within reasonable limits?
107
108 data PerModuleTableSpec =
109 forall a . Result a =>
110 SpecM
111 String -- Name of the table
112 String -- HTML tag for the table
113 (Results -> Map String a) -- get the module map
114 (a -> Bool) -- Result within reasonable limits?
115
116 -- The various per-program aspects of execution that we can generate results for.
117 size_spec, alloc_spec, runtime_spec, elapsedtime_spec, muttime_spec, mutetime_spec,
118 gctime_spec, gcelap_spec,
119 gcwork_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec,
120 gc0time_spec, gc0elap_spec, gc1time_spec, gc1elap_spec, balance_spec
121 :: PerProgTableSpec
122 size_spec = SpecP "Binary Sizes" "Size" "binary-sizes" binary_size compile_status always_ok
123 alloc_spec = SpecP "Allocations" "Allocs" "allocations" allocs run_status always_ok
124 runtime_spec = SpecP "Run Time" "Runtime" "run-times" (mean run_time) run_status time_ok
125 elapsedtime_spec = SpecP "Elapsed Time" "Elapsed" "elapsed-times" (mean elapsed_time) run_status time_ok
126 muttime_spec = SpecP "Mutator Time" "MutTime" "mutator-time" (mean mut_time) run_status time_ok
127 mutetime_spec = SpecP "Mutator Elapsed Time" "MutETime" "mutator-elapsed-time" (mean mut_elapsed_time) run_status time_ok
128 gctime_spec = SpecP "GC Time" "GCTime" "gc-time" (mean gc_time) run_status time_ok
129 gcelap_spec = SpecP "GC Elapsed Time" "GCETime" "gc-elapsed-time" (mean gc_elapsed_time) run_status time_ok
130 gc0time_spec = SpecP "GC(0) Time" "GC0Time" "gc0-time" (mean gc0_time) run_status time_ok
131 gc0elap_spec = SpecP "GC(0) Elapsed Time" "GC0ETime" "gc0-elapsed-time" (mean gc0_elapsed_time) run_status time_ok
132 gc1time_spec = SpecP "GC(1) Time" "GC1Time" "gc1-time" (mean gc1_time) run_status time_ok
133 gc1elap_spec = SpecP "GC(1) Elapsed Time" "GC1ETime" "gc1-elapsed-time" (mean gc1_elapsed_time) run_status time_ok
134 balance_spec = SpecP "GC work balance" "Balance" "balance" (mean balance) run_status time_ok
135 gcwork_spec = SpecP "GC Work" "GCWork" "gc-work" gc_work run_status always_ok
136 instrs_spec = SpecP "Instructions" "Instrs" "instrs" instrs run_status always_ok
137 mreads_spec = SpecP "Memory Reads" "Reads" "mem-reads" mem_reads run_status always_ok
138 mwrite_spec = SpecP "Memory Writes" "Writes" "mem-writes" mem_writes run_status always_ok
139 cmiss_spec = SpecP "Cache Misses" "Misses" "cache-misses" cache_misses run_status always_ok
140
141 all_specs :: [PerProgTableSpec]
142 all_specs = [
143 size_spec,
144 alloc_spec,
145 runtime_spec,
146 elapsedtime_spec,
147 muttime_spec,
148 mutetime_spec,
149 gctime_spec,
150 gcelap_spec,
151 gc0time_spec,
152 gc0elap_spec,
153 gc1time_spec,
154 gc1elap_spec,
155 balance_spec,
156 gcwork_spec,
157 instrs_spec,
158 mreads_spec,
159 mwrite_spec,
160 cmiss_spec
161 ]
162
163 namedColumns :: [String] -> IO [PerProgTableSpec]
164 namedColumns ss = mapM findSpec ss
165 where findSpec s =
166 case [ spec | spec@(SpecP _ short_name _ _ _ _) <- all_specs,
167 short_name == s ] of
168 [] -> die ("unknown column: " ++ s)
169 (spec:_) -> return spec
170
171 mean :: (Results -> [Float]) -> Results -> Maybe Float
172 mean f results = go (f results)
173 where go [] = Nothing
174 go fs = Just (foldl' (+) 0 fs / fromIntegral (length fs))
175
176 -- Look for bogus-looking times: On Linux we occasionally get timing results
177 -- that are bizarrely low, and skew the average.
178 checkTimes :: String -> Results -> IO ()
179 checkTimes prog results = do
180 check "run time" (run_time results)
181 check "mut time" (mut_time results)
182 check "GC time" (gc_time results)
183 where
184 check kind ts
185 | any strange ts =
186 hPutStrLn stderr ("warning: dubious " ++ kind
187 ++ " results for " ++ prog
188 ++ ": " ++ show ts)
189 | otherwise = return ()
190 where strange t = any (\r -> time_ok r && r / t > 1.4) ts
191 -- looks for times that are >40% smaller than
192 -- any other.
193
194
195 -- These are the per-prog tables we want to generate
196 per_prog_result_tab :: [PerProgTableSpec]
197 per_prog_result_tab =
198 [ size_spec, alloc_spec, runtime_spec, elapsedtime_spec, muttime_spec, mutetime_spec, gctime_spec,
199 gcelap_spec, gc0time_spec, gc0elap_spec, gc1time_spec, gc1elap_spec,
200 gcwork_spec, balance_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec]
201
202 -- A single summary table, giving comparison figures for a number of
203 -- aspects, each in its own column. Only works when comparing two runs.
204 normal_summary_specs :: [PerProgTableSpec]
205 normal_summary_specs =
206 [ size_spec, alloc_spec, runtime_spec, elapsedtime_spec ]
207
208 cachegrind_summary_specs :: [PerProgTableSpec]
209 cachegrind_summary_specs =
210 [ size_spec, alloc_spec, instrs_spec, mreads_spec, mwrite_spec ]
211
212 -- Pick an appropriate summary table: if we're cachegrinding, then
213 -- we're probably not interested in the runtime, but we are interested
214 -- in instructions, mem reads and mem writes (and vice-versa).
215 pickSummary :: [ResultTable] -> [PerProgTableSpec]
216 pickSummary rs
217 | isNothing (instrs (head (Map.elems (head rs)))) = normal_summary_specs
218 | otherwise = cachegrind_summary_specs
219
220 per_module_result_tab :: [PerModuleTableSpec]
221 per_module_result_tab =
222 [ SpecM "Module Sizes" "mod-sizes" module_size always_ok
223 , SpecM "Compile Times" "compile-time" compile_time time_ok
224 ]
225
226 always_ok :: a -> Bool
227 always_ok = const True
228
229 time_ok :: Float -> Bool
230 time_ok t = t > tooquick_threshold
231
232 -----------------------------------------------------------------------------
233 -- HTML page generation
234
235 htmlPage :: [ResultTable] -> [String] -> Html
236 htmlPage results args
237 = header << thetitle << reportTitle
238 +++ hr
239 +++ h1 << reportTitle
240 +++ gen_menu
241 +++ hr
242 +++ body (gen_tables results args)
243
244 gen_menu :: Html
245 gen_menu = unordList (map (prog_menu_item) per_prog_result_tab
246 ++ map (module_menu_item) per_module_result_tab)
247
248 prog_menu_item :: PerProgTableSpec -> Html
249 prog_menu_item (SpecP long_name _ anc _ _ _)
250 = anchor <! [href ('#':anc)] << long_name
251 module_menu_item :: PerModuleTableSpec -> Html
252 module_menu_item (SpecM long_name anc _ _)
253 = anchor <! [href ('#':anc)] << long_name
254
255 gen_tables :: [ResultTable] -> [String] -> Html
256 gen_tables results args =
257 foldr1 (+++) (map (htmlGenProgTable results args) per_prog_result_tab)
258 +++ foldr1 (+++) (map (htmlGenModTable results args) per_module_result_tab)
259
260 htmlGenProgTable :: [ResultTable] -> [String] -> PerProgTableSpec -> Html
261 htmlGenProgTable results args (SpecP long_name _ anc get_result get_status result_ok)
262 = sectHeading long_name anc
263 +++ font <! [size "1"]
264 << mkTable (htmlShowResults results args get_result get_status result_ok)
265 +++ hr
266
267 htmlGenModTable :: [ResultTable] -> [String] -> PerModuleTableSpec -> Html
268 htmlGenModTable results args (SpecM long_name anc get_result result_ok)
269 = sectHeading long_name anc
270 +++ font <![size "1"]
271 << mkTable (htmlShowMultiResults results args get_result result_ok)
272 +++ hr
273
274 sectHeading :: String -> String -> Html
275 sectHeading s nm = h2 << anchor <! [name nm] << s
276
277 htmlShowResults
278 :: Result a
279 => [ResultTable]
280 -> [String]
281 -> (Results -> Maybe a)
282 -> (Results -> Status)
283 -> (a -> Bool)
284 -> HtmlTable
285
286 htmlShowResults [] _ _ _ _
287 = error "htmlShowResults: Can't happen?"
288 htmlShowResults (r:rs) ss f stat result_ok
289 = tabHeader ss
290 </> aboves (zipWith tableRow [1..] results_per_prog)
291 </> aboves ((if nodevs then []
292 else [tableRow (-1) ("-1 s.d.", lows),
293 tableRow (-1) ("+1 s.d.", highs)])
294 ++ [tableRow (-1) ("Average", gms)])
295 where
296 -- results_per_prog :: [ (String,[BoxValue a]) ]
297 results_per_prog = map (calc_result rs f stat result_ok convert_to_percentage) (Map.toList r)
298
299 results_per_run = transpose (map snd results_per_prog)
300 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
301
302 htmlShowMultiResults
303 :: Result a
304 => [ResultTable]
305 -> [String]
306 -> (Results -> Map String a)
307 -> (a -> Bool)
308 -> HtmlTable
309
310 htmlShowMultiResults [] _ _ _
311 = error "htmlShowMultiResults: Can't happen?"
312 htmlShowMultiResults (r:rs) ss f result_ok =
313 multiTabHeader ss
314 </> aboves (map show_results_for_prog results_per_prog_mod_run)
315 </> aboves ((if nodevs then []
316 else [td << bold << "-1 s.d."
317 <-> tableRow (-1) ("", lows),
318 td << bold << "+1 s.d."
319 <-> tableRow (-1) ("", highs)])
320 ++ [td << bold << "Average"
321 <-> tableRow (-1) ("", gms)])
322 where
323 base_results = Map.toList r :: [(String,Results)]
324
325 -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
326 results_per_prog_mod_run = map get_results_for_prog base_results
327
328 -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
329 get_results_for_prog (prog, results)
330 = (prog, map get_results_for_mod (Map.toList (f results)))
331
332 where fms = map get_run_results rs
333
334 get_run_results fm = case Map.lookup prog fm of
335 Nothing -> Map.empty
336 Just res -> f res
337
338 get_results_for_mod id_attr
339 = calc_result fms Just (const Success) result_ok convert_to_percentage id_attr
340
341 show_results_for_prog (prog,mrs) =
342 td <! [valign "top"] << bold << prog
343 <-> (if null mrs then
344 td << "(no modules compiled)"
345 else
346 toHtml (aboves (map (tableRow 0) mrs)))
347
348 results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run,
349 (_,xs) <- mods]
350 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
351
352 tableRow :: Int -> (String, [BoxValue]) -> HtmlTable
353 tableRow row_no (prog, results)
354 = td <! [bgcolor left_column_color] << prog
355 <-> besides (map (\s -> td <! [align "right", clr] << showBox s)
356 results)
357 where clr | row_no < 0 = bgcolor average_row_color
358 | even row_no = bgcolor even_row_color
359 | otherwise = bgcolor odd_row_color
360
361 left_column_color, odd_row_color, even_row_color, average_row_color :: String
362 left_column_color = "#d0d0ff" -- light blue
363 odd_row_color = "#d0d0ff" -- light blue
364 even_row_color = "#f0f0ff" -- v. light blue
365 average_row_color = "#ffd0d0" -- light red
366
367 {-
368 findBest :: Result a => [BoxValue a] -> [(Bool,BoxValue a)]
369 findBest stuff@(Result base : rest)
370 = map (\a -> (a==base, a))
371 where
372 best = snd (minimumBy (\a b -> fst a < fst b) no_pcnt_stuff
373
374 no_pcnt_stuff = map unPcnt stuff
375
376 unPcnt (r@(Percentage f) : rest) = (base * f/100, r) : unPcnt rest
377 unPcnt (r@(Result a) : rest) = (a, r) : unPcnt rest
378 unPcnt (_ : rest) = unPcnt rest
379 -}
380
381 logHeaders :: [String] -> HtmlTable
382 logHeaders ss
383 = besides (map (\s -> (td <! [align "right", width "100"] << bold << s)) ss)
384
385 mkTable :: HtmlTable -> Html
386 mkTable t = table <! [cellspacing 0, cellpadding 0, border 0] << t
387
388 tabHeader :: [String] -> HtmlTable
389 tabHeader ss
390 = (td <! [align "left", width "100"] << bold << "Program")
391 <-> logHeaders ss
392
393 multiTabHeader :: [String] -> HtmlTable
394 multiTabHeader ss
395 = (td <! [align "left", width "100"] << bold << "Program")
396 <-> (td <! [align "left", width "100"] << bold << "Module")
397 <-> logHeaders ss
398
399 -- Calculate a color ranging from bright blue for -100% to bright red for +100%.
400 calcColor :: Int -> String
401 calcColor percentage | percentage >= 0 = printf "#%02x0000" val
402 | otherwise = printf "#0000%02x" val
403 where val = abs percentage * 255 `div` 100
404
405 -----------------------------------------------------------------------------
406 -- LaTeX table generation (just the summary for now)
407
408 latexOutput :: [ResultTable] -> Maybe String -> [String] -> [PerProgTableSpec]
409 -> Maybe [String] -> Normalise -> String
410
411 latexOutput results (Just table_name) _ _ _ norm
412 = let
413 table_spec = [ spec | spec@(SpecP _ n _ _ _ _) <- per_prog_result_tab,
414 n == table_name ]
415 in
416 case table_spec of
417 [] -> error ("can't find table named: " ++ table_name)
418 (spec:_) -> latexProgTable results spec norm "\n"
419
420 latexOutput results Nothing _ summary_spec summary_rows _ =
421 (if (length results == 2)
422 then ascii_summary_table True results summary_spec summary_rows
423 . str "\n\n"
424 else id) ""
425
426
427 latexProgTable :: [ResultTable] -> PerProgTableSpec -> Normalise -> ShowS
428 latexProgTable results (SpecP _long_name _ _ get_result get_status result_ok) norm
429 = latex_show_results results get_result get_status result_ok norm
430
431 latex_show_results
432 :: Result a
433 => [ResultTable]
434 -> (Results -> Maybe a)
435 -> (Results -> Status)
436 -> (a -> Bool)
437 -> Normalise
438 -> ShowS
439
440 latex_show_results [] _ _ _ _
441 = error "latex_show_results: Can't happen?"
442 latex_show_results (r:rs) f stat _result_ok norm
443 = makeLatexTable $
444 [ TableRow (BoxString prog : boxes) |
445 (prog,boxes) <- results_per_prog ] ++
446 if nodevs then [] else
447 [ TableLine,
448 TableRow (BoxString "Min" : mins),
449 TableRow (BoxString "Max" : maxs),
450 TableRow (BoxString "Geometric Mean" : gms) ]
451 where
452 -- results_per_prog :: [ (String,[BoxValue a]) ]
453 results_per_prog = [ (prog,tail xs) | (prog,xs) <- map calc (Map.toList r) ]
454 calc = calc_result rs f stat (const True) (normalise norm)
455
456 results_per_run = transpose (map snd results_per_prog)
457 (_lows,gms,_highs) = unzip3 (map calc_gmsd results_per_run)
458 (mins, maxs) = unzip (map calc_minmax results_per_run)
459
460 normalise :: Result a => Normalise -> a -> a -> BoxValue
461 normalise norm = case norm of
462 NormalisePercent -> convert_to_percentage
463 NormaliseRatio -> normalise_to_base
464 NormaliseNone -> \_base res -> toBox res
465
466 -----------------------------------------------------------------------------
467 -- ASCII page generation
468
469 asciiPage :: [ResultTable] -> [String] -> [PerProgTableSpec] -> Maybe [String]
470 -> Normalise
471 -> String
472 asciiPage results args summary_spec summary_rows norm =
473 ( str reportTitle
474 . str "\n\n"
475 -- only show the summary table if we're comparing two runs
476 . (if (length results == 2)
477 then ascii_summary_table False results summary_spec summary_rows . str "\n\n"
478 else id)
479 . interleave "\n\n" (map (asciiGenProgTable results args norm) per_prog_result_tab)
480 . str "\n"
481 . interleave "\n\n" (map (asciiGenModTable results args) per_module_result_tab)
482 ) "\n"
483
484 asciiGenProgTable :: [ResultTable] -> [String] -> Normalise -> PerProgTableSpec -> ShowS
485 asciiGenProgTable results args norm (SpecP long_name _ _ get_result get_status result_ok)
486 = str long_name
487 . str "\n"
488 . ascii_show_results results args get_result get_status result_ok norm
489
490 asciiGenModTable :: [ResultTable] -> [String] -> PerModuleTableSpec -> ShowS
491 asciiGenModTable results args (SpecM long_name _ get_result result_ok)
492 = str long_name
493 . str "\n"
494 . ascii_show_multi_results results args get_result result_ok
495
496 ascii_header :: Int -> [String] -> ShowS
497 ascii_header w ss
498 = str "\n-------------------------------------------------------------------------------\n"
499 . str (rjustify 15 "Program")
500 . str (space 5)
501 . foldr (.) id (map (str . rjustify w) ss)
502 . str "\n-------------------------------------------------------------------------------\n"
503
504 ascii_show_results
505 :: Result a
506 => [ResultTable]
507 -> [String]
508 -> (Results -> Maybe a)
509 -> (Results -> Status)
510 -> (a -> Bool)
511 -> Normalise
512 -> ShowS
513
514 ascii_show_results [] _ _ _ _ _
515 = error "ascii_show_results: Can't happen?"
516 ascii_show_results (r:rs) ss f stat result_ok norm
517 = ascii_header fIELD_WIDTH ss
518 . interleave "\n" (map show_per_prog_results results_per_prog)
519 . if nodevs then id
520 else str "\n"
521 . show_per_prog_results ("-1 s.d.",lows)
522 . str "\n"
523 . show_per_prog_results ("+1 s.d.",highs)
524 . str "\n"
525 . show_per_prog_results ("Average",gms)
526 where
527 -- results_per_prog :: [ (String,[BoxValue a]) ]
528 results_per_prog = map (calc_result rs f stat result_ok (normalise norm)) (Map.toList r)
529
530 results_per_run = transpose (map snd results_per_prog)
531 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
532
533 -- A summary table, useful only when we are comparing two runs. This table
534 -- shows a number of different result categories, one per column.
535 ascii_summary_table
536 :: Bool -- generate a LaTeX table?
537 -> [ResultTable]
538 -> [PerProgTableSpec]
539 -> Maybe [String]
540 -> ShowS
541 ascii_summary_table _ [] _ _
542 = error "ascii_summary_table: Can't happen?"
543 ascii_summary_table _ [_] _ _
544 = error "ascii_summary_table: Can't happen?"
545 ascii_summary_table latex (r1:r2:_) specs mb_restrict
546 | latex = makeLatexTable (rows ++ TableLine : av_rows)
547 | otherwise =
548 makeTable (table_layout (length specs) w)
549 (TableLine : TableRow header_row :
550 TableLine : rows ++
551 TableLine : av_rows)
552 where
553 header_row = BoxString "Program" : map BoxString headings
554
555 (headings, columns, av_cols) = unzip3 (map calc_col specs)
556 av_heads = [BoxString "Min", BoxString "Max", BoxString "Geometric Mean"]
557 baseline = Map.toList r1
558 progs = map BoxString (Map.keys r1)
559 rows0 = map TableRow (zipWith (:) progs (transpose columns))
560
561 rows1 = restrictRows mb_restrict rows0
562
563 rows | latex = mungeForLaTeX rows1
564 | otherwise = rows1
565
566 av_rows = map TableRow (zipWith (:) av_heads (transpose av_cols))
567 w = 10
568
569 calc_col (SpecP _ heading _ getr gets ok)
570 -- throw away the baseline result
571 = (heading, column, [column_min, column_max, column_mean])
572 where (_, boxes) = unzip (map calc_one_result baseline)
573 calc_one_result = calc_result [r2] getr gets ok convert_to_percentage
574 column = map (\(_:b:_) -> b) boxes
575 (_, column_mean, _) = calc_gmsd column
576 (column_min, column_max) = calc_minmax column
577
578 restrictRows :: Maybe [String] -> [TableRow] -> [TableRow]
579 restrictRows Nothing rows = rows
580 restrictRows (Just these) rows = filter keep_it rows
581 where keep_it (TableRow (BoxString s: _)) = s `elem` these
582 keep_it TableLine = True
583 keep_it _ = False
584
585 mungeForLaTeX :: [TableRow] -> [TableRow]
586 mungeForLaTeX = map transrow
587 where
588 transrow (TableRow boxes) = TableRow (map transbox boxes)
589 transrow row = row
590
591 transbox (BoxString s) = BoxString (foldr transchar "" s)
592 transbox box = box
593
594 transchar '_' s = '\\':'_':s
595 transchar c s = c:s
596
597 table_layout :: Int -> Int -> Layout
598 table_layout n w boxes = foldr (.) id $ zipWith ($) fns boxes
599 where fns = (str . rjustify 15 . show ) :
600 (\s -> str (space 5) . str (rjustify w (show s))) :
601 replicate (n-1) (str . rjustify w . show)
602
603 ascii_show_multi_results
604 :: Result a
605 => [ResultTable]
606 -> [String]
607 -> (Results -> Map String a)
608 -> (a -> Bool)
609 -> ShowS
610
611 ascii_show_multi_results [] _ _ _
612 = error "ascii_show_multi_results: Can't happen?"
613 ascii_show_multi_results (r:rs) ss f result_ok
614 = ascii_header fIELD_WIDTH ss
615 . interleave "\n" (map show_results_for_prog results_per_prog_mod_run)
616 . str "\n"
617 . if nodevs then id
618 else str "\n"
619 . show_per_prog_results ("-1 s.d.",lows)
620 . str "\n"
621 . show_per_prog_results ("+1 s.d.",highs)
622 . str "\n"
623 . show_per_prog_results ("Average",gms)
624 where
625 base_results = Map.toList r :: [(String,Results)]
626
627 -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
628 results_per_prog_mod_run = map get_results_for_prog base_results
629
630 -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
631 get_results_for_prog (prog, results)
632 = (prog, map get_results_for_mod (Map.toList (f results)))
633
634 where fms = map get_run_results rs
635
636 get_run_results fm = case Map.lookup prog fm of
637 Nothing -> Map.empty
638 Just res -> f res
639
640 get_results_for_mod id_attr
641 = calc_result fms Just (const Success) result_ok convert_to_percentage id_attr
642
643 show_results_for_prog (prog,mrs) =
644 str ("\n"++prog++"\n")
645 . (if null mrs then
646 str "(no modules compiled)\n"
647 else
648 interleave "\n" (map show_per_prog_results mrs))
649
650 results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run,
651 (_,xs) <- mods]
652 (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
653
654
655 show_per_prog_results :: (String, [BoxValue]) -> ShowS
656 show_per_prog_results = show_per_prog_results_width fIELD_WIDTH
657
658 show_per_prog_results_width :: Int -> (String, [BoxValue]) -> ShowS
659 show_per_prog_results_width w (prog,results)
660 = str (rjustify 15 prog)
661 . str (space 5)
662 . foldr (.) id (map (str . rjustify w . showBox) results)
663
664 -- -----------------------------------------------------------------------------
665 -- CSV output
666
667 csvTable :: [ResultTable] -> String -> Normalise -> String
668 csvTable results table_name norm
669 = let
670 table_spec = [ spec | spec@(SpecP _ n _ _ _ _) <- per_prog_result_tab,
671 n == table_name ]
672 in
673 case table_spec of
674 [] -> error ("can't find table named: " ++ table_name)
675 (spec:_) -> csvProgTable results spec norm "\n"
676
677 csvProgTable :: [ResultTable] -> PerProgTableSpec -> Normalise -> ShowS
678 csvProgTable results (SpecP _long_name _ _ get_result get_status result_ok) norm
679 = csv_show_results results get_result get_status result_ok norm
680
681 csv_show_results
682 :: Result a
683 => [ResultTable]
684 -> (Results -> Maybe a)
685 -> (Results -> Status)
686 -> (a -> Bool)
687 -> Normalise
688 -> ShowS
689
690 csv_show_results [] _ _ _ _
691 = error "csv_show_results: Can't happen?"
692 csv_show_results (r:rs) f stat _result_ok norm
693 = interleave "\n" results_per_prog
694 where
695 -- results_per_prog :: [ (String,[BoxValue a]) ]
696 results_per_prog = map (result_line . calc) (Map.toList r)
697 calc = calc_result rs f stat (const True) (normalise norm)
698
699 result_line (prog,boxes) = interleave "," (str prog : map (str.showBox) boxes)
700
701 -- ---------------------------------------------------------------------------
702 -- Generic stuff for results generation
703
704 -- calc_result is a nice exercise in higher-order programming...
705 calc_result
706 :: Result a
707 => [Map String b] -- accumulated results
708 -> (b -> Maybe a) -- get a result from the b
709 -> (b -> Status) -- get a status from the b
710 -> (a -> Bool) -- normalise against the baseline?
711 -> (a -> a -> BoxValue) -- how to normalise
712 -> (String,b) -- the baseline result
713 -> (String,[BoxValue])
714
715 calc_result rts get_maybe_a get_stat base_ok norm_fn (prog,base_r) =
716 (prog, (just_result m_baseline base_stat :
717
718 let
719 rts' = map (\rt -> get_stuff (Map.lookup prog rt)) rts
720
721 get_stuff Nothing = (Nothing, NotDone)
722 get_stuff (Just r) = (get_maybe_a r, get_stat r)
723 in
724 (
725 case m_baseline of
726 Just baseline | base_ok baseline
727 -> map (\(r,s) -> do_norm r s baseline) rts'
728 _other
729 -> map (\(r,s) -> just_result r s) rts'
730 )))
731 where
732 m_baseline = get_maybe_a base_r
733 base_stat = get_stat base_r
734
735 just_result Nothing s = RunFailed s
736 just_result (Just a) _ = toBox a
737
738 do_norm Nothing s _ = RunFailed s
739 do_norm (Just a) _ baseline = norm_fn baseline a
740
741 -----------------------------------------------------------------------------
742 -- Calculating geometric means and standard deviations
743
744 {-
745 This is done using the log method, to avoid needing really large
746 intermediate results. The formula for a geometric mean is
747
748 (a1 * .... * an) ^ 1/n
749
750 which is equivalent to
751
752 e ^ ( (log a1 + ... + log an) / n )
753
754 where log is the natural logarithm function.
755
756 Similarly, to compute the geometric standard deviation we compute the
757 deviation of each log, take the root-mean-square, and take the
758 exponential again:
759
760 e ^ sqrt( ( sqr(log a1 - lbar) + ... + sqr(log an - lbar) ) / n )
761
762 where lbar is the mean log,
763
764 (log a1 + ... + log an) / n
765
766 This is a *factor*: i.e., the 1 s.d. points are (gm/sdf,gm*sdf); do
767 not subtract 100 from gm before performing this calculation.
768
769 We therefore return a (low, mean, high) triple.
770
771 -}
772
773 calc_gmsd :: [BoxValue] -> (BoxValue, BoxValue, BoxValue)
774 calc_gmsd xs
775 | null percentages = (RunFailed NotDone, RunFailed NotDone, RunFailed NotDone)
776 | otherwise = let sqr x = x * x
777 len = fromIntegral (length percentages)
778 logs = map log percentages
779 lbar = sum logs / len
780 st_devs = map (sqr . (lbar-)) logs
781 dbar = sum st_devs / len
782 gm = exp lbar
783 sdf = exp (sqrt dbar)
784 in
785 (Percentage (gm/sdf),
786 Percentage gm,
787 Percentage (gm*sdf))
788 where
789 percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]
790 -- can't do log(0.0), so exclude zeros
791 -- small values have inordinate effects so cap at -95%.
792
793 calc_minmax :: [BoxValue] -> (BoxValue, BoxValue)
794 calc_minmax xs
795 | null percentages = (RunFailed NotDone, RunFailed NotDone)
796 | otherwise = (Percentage (minimum percentages),
797 Percentage (maximum percentages))
798 where
799 percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]
800
801
802 -----------------------------------------------------------------------------
803 -- Show the Results
804
805 convert_to_percentage :: Result a => a -> a -> BoxValue
806 convert_to_percentage 0 _val = Percentage 100
807 convert_to_percentage baseline val = Percentage ((realToFrac val / realToFrac baseline) * 100)
808
809 normalise_to_base :: Result a => a -> a -> BoxValue
810 normalise_to_base 0 _val = BoxFloat 1
811 normalise_to_base baseline val = BoxFloat (realToFrac baseline / realToFrac val)
812
813 class Real a => Result a where
814 toBox :: a -> BoxValue
815
816 -- We assume an Int is a size, and print it in kilobytes.
817
818 instance Result Int where
819 toBox = BoxInt
820
821 instance Result Integer where
822 toBox = BoxInteger
823
824 instance Result Float where
825 toBox = BoxFloat
826
827 -- -----------------------------------------------------------------------------
828 -- BoxValues
829
830 -- The contents of a box in a table
831 data BoxValue
832 = RunFailed Status
833 | Percentage Float
834 | BoxFloat Float
835 | BoxInt Int
836 | BoxInteger Integer
837 | BoxString String
838
839 showBox :: BoxValue -> String
840 showBox (RunFailed stat) = show_stat stat
841 showBox (Percentage f) = case printf "%.1f%%" (f-100) of
842 xs@('-':_) -> xs
843 xs -> '+':xs
844 showBox (BoxFloat f) = printf "%.2f" f
845 showBox (BoxInt n) = show (n `div` 1024) ++ "k"
846 showBox (BoxInteger n) = show (n `div` 1024) ++ "k"
847 showBox (BoxString s) = s
848
849 instance Show BoxValue where
850 show = showBox
851
852 show_stat :: Status -> String
853 show_stat Success = "(no result)"
854 show_stat WrongStdout = "(stdout)"
855 show_stat WrongStderr = "(stderr)"
856 show_stat (Exit x) = "exit(" ++ show x ++")"
857 show_stat OutOfHeap = "(heap)"
858 show_stat OutOfStack = "(stack)"
859 show_stat NotDone = "-----"
860
861 -- -----------------------------------------------------------------------------
862 -- Table layout
863
864 data TableRow
865 = TableRow [BoxValue]
866 | TableLine
867
868 type Layout = [BoxValue] -> ShowS
869
870 makeTable :: Layout -> [TableRow] -> ShowS
871 makeTable layout = interleave "\n" . map do_row
872 where do_row (TableRow boxes) = layout boxes
873 do_row TableLine = str (take 80 (repeat '-'))
874
875 makeLatexTable :: [TableRow] -> ShowS
876 makeLatexTable = foldr (.) id . map do_row
877 where do_row (TableRow boxes)
878 = latexTableLayout boxes . str "\\\\\n"
879 do_row TableLine
880 = str "\\hline\n"
881
882 latexTableLayout :: Layout
883 latexTableLayout boxes =
884 foldr (.) id . intersperse (str " & ") . map abox $ boxes
885 where
886 abox (RunFailed NotDone) = id
887 abox s = str (foldr transchar "" (show s))
888
889 transchar '%' s = s -- leave out the percentage signs
890 transchar c s = c : s
891
892 -- -----------------------------------------------------------------------------
893 -- General Utils
894
895 split :: Char -> String -> [String]
896 split c s = case break (==c) s of
897 (chunk, rest) ->
898 case rest of
899 [] -> [chunk]
900 _:rest' -> chunk : split c rest'
901
902 str :: String -> ShowS
903 str = showString
904
905 interleave :: String -> [ShowS] -> ShowS
906 interleave s = foldr1 (\a b -> a . str s . b)
907
908 fIELD_WIDTH :: Int
909 fIELD_WIDTH = 16
910
911 -----------------------------------------------------------------------------