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