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