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