utils/nofib-analyse/Main.hs

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