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