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