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