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 title _ anc get_result get_status result_ok)
 231   =   sectHeading title 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 title anc get_result result_ok)
 238   =   sectHeading title 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 (r:rs) ss f stat result_ok
 256   =   tabHeader ss
 257   </> aboves (zipWith tableRow [1..] results_per_prog)
 258   </> aboves ((if nodevs then []
 259                          else [tableRow (-1) ("-1 s.d.", lows),
 260                                tableRow (-1) ("+1 s.d.", highs)])
 261                     ++ [tableRow (-1) ("Average", gms)])
 262  where
 263         -- results_per_prog :: [ (String,[BoxValue a]) ]
 264         results_per_prog = map (calc_result rs f stat result_ok) (Map.toList r)
 265
 266         results_per_run  = transpose (map snd results_per_prog)
 267         (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
 268
 269 htmlShowMultiResults
 270     :: Result a
 271         => [ResultTable]
 272         -> [String]
 273         -> (Results -> Map String a)
 274         -> (a -> Bool)
 275         -> HtmlTable
 276
 277 htmlShowMultiResults (r:rs) ss f result_ok =
 278         multiTabHeader ss
 279          </> aboves (map show_results_for_prog results_per_prog_mod_run)
 280          </> aboves ((if nodevs then []
 281                                       else [td << bold << "-1 s.d."
 282                                             <-> tableRow (-1) ("", lows),
 283                                             td << bold << "+1 s.d."
 284                                             <-> tableRow (-1) ("", highs)])
 285                            ++ [td << bold << "Average"
 286                                <-> tableRow (-1) ("", gms)])
 287
 288   where
 289         base_results = Map.toList r :: [(String,Results)]
 290
 291         -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
 292         results_per_prog_mod_run = map get_results_for_prog base_results
 293
 294         -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
 295         get_results_for_prog (prog, results)
 296             = (prog, map get_results_for_mod (Map.toList (f results)))
 297
 298            where fms = map get_run_results rs
 299
 300                  get_run_results fm = case Map.lookup prog fm of
 301                                         Nothing  -> Map.empty
 302                                         Just res -> f res
 303
 304                  get_results_for_mod id_attr
 305                      = calc_result fms Just (const Success) result_ok id_attr
 306
 307         show_results_for_prog (prog,mrs) =
 308             td <! [valign "top"] << bold << prog
 309             <-> (if null mrs then
 310                    td << "(no modules compiled)"
 311                  else
 312                    toHtml (aboves (map (tableRow 0) mrs)))
 313
 314         results_per_run  = transpose [xs | (_,mods) <- results_per_prog_mod_run,
 315                                            (_,xs) <- mods]
 316         (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
 317
 318 tableRow :: Int -> (String, [BoxValue]) -> HtmlTable
 319 tableRow row_no (prog, results)
 320         =   td <! [bgcolor left_column_color] << prog
 321         <-> besides (map (\s -> td <! [align "right", clr] << showBox s)
 322                                 results)
 323   where clr | row_no < 0  = bgcolor average_row_color
 324             | even row_no = bgcolor even_row_color
 325             | otherwise   = bgcolor odd_row_color
 326
 327 left_column_color = "#d0d0ff"  -- light blue
 328 odd_row_color     = "#d0d0ff"  -- light blue
 329 even_row_color    = "#f0f0ff"  -- v. light blue
 330 average_row_color = "#ffd0d0"  -- light red
 331
 332 {-
 333 findBest :: Result a => [BoxValue a] -> [(Bool,BoxValue a)]
 334 findBest stuff@(Result base : rest)
 335   = map (\a -> (a==base, a))
 336   where
 337         best = snd (minimumBy (\a b -> fst a < fst b) no_pcnt_stuff
 338
 339         no_pcnt_stuff = map unPcnt stuff
 340
 341         unPcnt (r@(Percentage f) : rest) = (base * f/100, r) : unPcnt rest
 342         unPcnt (r@(Result a) : rest)     = (a, r) : unPcnt rest
 343         unPcnt (_ : rest)                = unPcnt rest
 344 -}
 345
 346 logHeaders :: [String] -> HtmlTable
 347 logHeaders ss
 348   = besides (map (\s -> (td <! [align "right", width "100"] << bold << s)) ss)
 349
 350 mkTable :: HtmlTable -> Html
 351 mkTable t = table <! [cellspacing 0, cellpadding 0, border 0] << t
 352
 353 tabHeader :: [String] -> HtmlTable
 354 tabHeader ss
 355   =   (td <! [align "left", width "100"] << bold << "Program")
 356   <-> logHeaders ss
 357
 358 multiTabHeader :: [String] -> HtmlTable
 359 multiTabHeader ss
 360   =   (td <! [align "left", width "100"] << bold << "Program")
 361   <-> (td <! [align "left", width "100"] << bold << "Module")
 362   <-> logHeaders ss
 363
 364 -- Calculate a color ranging from bright blue for -100% to bright red for +100%.
 365 calcColor :: Int -> String
 366 calcColor percentage | percentage >= 0 = "#"     ++ (showHex val 2 "0000")
 367                      | otherwise       = "#0000" ++ (showHex val 2 "")
 368         where val = abs percentage * 255 `div` 100
 369
 370 showHex 0 f s = if f > 0 then take f (repeat '0') ++ s else s
 371 showHex i f s = showHex (i `div` 16) (f-1) (hexDig (i `mod` 16) : s)
 372
 373 hexDig i | i > 10 = chr (i-10 + ord 'a')
 374          | otherwise = chr (i + ord '0')
 375
 376 -----------------------------------------------------------------------------
 377 -- LaTeX table generation (just the summary for now)
 378
 379 latexOutput results args 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 results args summary_spec summary_rows =
 390   ( str reportTitle
 391   . str "\n\n"
 392      -- only show the summary table if we're comparing two runs
 393   . (if (length results == 2)
 394         then ascii_summary_table False results summary_spec summary_rows . str "\n\n"
 395         else id)
 396   . interleave "\n\n" (map (asciiGenProgTable results args) per_prog_result_tab)
 397   . str "\n"
 398   . interleave "\n\n" (map (asciiGenModTable results args)  per_module_result_tab)
 399   ) "\n"
 400
 401 asciiGenProgTable results args (SpecP title _ anc get_result get_status result_ok)
 402   = str title
 403   . str "\n"
 404   . ascii_show_results results args get_result get_status result_ok
 405
 406 asciiGenModTable results args (SpecM title anc get_result result_ok)
 407   = str title
 408   . str "\n"
 409   . ascii_show_multi_results results args get_result result_ok
 410
 411 ascii_header width ss
 412         = str "\n-------------------------------------------------------------------------------\n"
 413         . str (rjustify 15 "Program")
 414         . str (space 5)
 415         . foldr (.) id (map (str . rjustify width) ss)
 416         . str "\n-------------------------------------------------------------------------------\n"
 417
 418 ascii_show_results
 419    :: Result a
 420         => [ResultTable]
 421         -> [String]
 422         -> (Results -> Maybe a)
 423         -> (Results -> Status)
 424         -> (a -> Bool)
 425         -> ShowS
 426
 427 ascii_show_results (r:rs) ss f stat result_ok
 428         = ascii_header fIELD_WIDTH ss
 429         . interleave "\n" (map show_per_prog_results results_per_prog)
 430         . if nodevs then id
 431                     else   str "\n"
 432                          . show_per_prog_results ("-1 s.d.",lows)
 433                          . str "\n"
 434                          . show_per_prog_results ("+1 s.d.",highs)
 435         . str "\n"
 436         . show_per_prog_results ("Average",gms)
 437  where
 438         -- results_per_prog :: [ (String,[BoxValue a]) ]
 439         results_per_prog = map (calc_result rs f stat result_ok) (Map.toList r)
 440
 441         results_per_run  = transpose (map snd results_per_prog)
 442         (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
 443
 444 -- A summary table, useful only when we are comparing two runs.  This table
 445 -- shows a number of different result categories, one per column.
 446 ascii_summary_table
 447         :: Bool                         -- generate a LaTeX table?
 448         -> [ResultTable]
 449         -> [PerProgTableSpec]
 450         -> Maybe [String]
 451         -> ShowS
 452 ascii_summary_table latex (r1:r2:_) specs mb_restrict
 453   | latex     = makeLatexTable (rows ++ TableLine : av_rows)
 454   | otherwise =
 455        makeTable (table_layout (length specs) width)
 456           (TableLine : TableRow header : TableLine : rows ++ TableLine : av_rows)
 457   where
 458         header = BoxString "Program" : map BoxString headings
 459
 460         (headings, columns, av_cols) = unzip3 (map calc_col specs)
 461         av_heads = [BoxString "Min", BoxString "Max", BoxString "Geometric Mean"]
 462         baseline = Map.toList r1
 463         progs   = map BoxString (Map.keys r1)
 464         rows0   = map TableRow (zipWith (:) progs (transpose columns))
 465
 466         rows1 = restrictRows mb_restrict rows0
 467
 468         rows | latex     = mungeForLaTeX rows1
 469              | otherwise = rows1
 470
 471         av_rows = map TableRow (zipWith (:) av_heads (transpose av_cols))
 472         width   = 10
 473
 474         calc_col (SpecP _ heading _ getr gets ok)
 475             -- throw away the baseline result
 476           = (heading, column, [column_min, column_max, column_mean])
 477           where (_, boxes) = unzip (map calc_one_result baseline)
 478                 calc_one_result = calc_result [r2] getr gets ok
 479                 column = map (\(_:b:_) -> b) boxes
 480                 (_, column_mean, _) = calc_gmsd column
 481                 (column_min, column_max) = calc_minmax column
 482
 483 restrictRows :: Maybe [String] -> [TableRow] -> [TableRow]
 484 restrictRows Nothing rows = rows
 485 restrictRows (Just these) rows = filter keep_it rows
 486   where keep_it (TableRow (BoxString s: _)) = s `elem` these
 487         keep_it TableLine = True
 488         keep_it _ = False
 489
 490 mungeForLaTeX :: [TableRow] -> [TableRow]
 491 mungeForLaTeX = map transrow
 492    where
 493         transrow (TableRow boxes) = TableRow (map transbox boxes)
 494         transrow row = row
 495
 496         transbox (BoxString s) = BoxString (foldr transchar "" s)
 497         transbox box = box
 498
 499         transchar '_' s = '\\':'_':s
 500         transchar c s = c:s
 501
 502 table_layout n width =
 503   (str . rjustify 15) :
 504   (\s -> str (space 5) . str (rjustify width s)) :
 505   replicate (n-1) (str . rjustify width)
 506
 507 ascii_show_multi_results
 508    :: Result a
 509         => [ResultTable]
 510         -> [String]
 511         -> (Results -> Map String a)
 512         -> (a -> Bool)
 513         -> ShowS
 514
 515 ascii_show_multi_results (r:rs) ss f result_ok
 516         = ascii_header fIELD_WIDTH ss
 517         . interleave "\n" (map show_results_for_prog results_per_prog_mod_run)
 518         . str "\n"
 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         base_results = Map.toList r :: [(String,Results)]
 528
 529         -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
 530         results_per_prog_mod_run = map get_results_for_prog base_results
 531
 532         -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
 533         get_results_for_prog (prog, results)
 534             = (prog, map get_results_for_mod (Map.toList (f results)))
 535
 536            where fms = map get_run_results rs
 537
 538                  get_run_results fm = case Map.lookup prog fm of
 539                                         Nothing  -> Map.empty
 540                                         Just res -> f res
 541
 542                  get_results_for_mod id_attr
 543                      = calc_result fms Just (const Success) result_ok id_attr
 544
 545         show_results_for_prog (prog,mrs) =
 546               str ("\n"++prog++"\n")
 547             . (if null mrs then
 548                    str "(no modules compiled)\n"
 549                  else
 550                    interleave "\n" (map show_per_prog_results mrs))
 551
 552         results_per_run  = transpose [xs | (_,mods) <- results_per_prog_mod_run,
 553                                            (_,xs) <- mods]
 554         (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
 555
 556
 557 show_per_prog_results :: (String, [BoxValue]) -> ShowS
 558 show_per_prog_results = show_per_prog_results_width fIELD_WIDTH
 559
 560 show_per_prog_results_width width (prog,results)
 561         = str (rjustify 15 prog)
 562         . str (space 5)
 563         . foldr (.) id (map (str . rjustify width . showBox) results)
 564
 565 -- ---------------------------------------------------------------------------
 566 -- Generic stuff for results generation
 567
 568 -- calc_result is a nice exercise in higher-order programming...
 569 calc_result
 570   :: Result a
 571         => [Map String b]               -- accumulated results
 572         -> (b -> Maybe a)               -- get a result from the b
 573         -> (b -> Status)                -- get a status from the b
 574         -> (a -> Bool)                  -- is this result ok?
 575         -> (String,b)                   -- the baseline result
 576         -> (String,[BoxValue])
 577
 578 calc_result rts get_maybe_a get_stat result_ok (prog,base_r) =
 579         (prog, (just_result baseline base_stat :
 580
 581           let
 582                 rts' = map (\rt -> get_stuff (Map.lookup prog rt)) rts
 583
 584                 get_stuff Nothing  = (Nothing, NotDone)
 585                 get_stuff (Just r) = (get_maybe_a r, get_stat r)
 586           in
 587           (
 588           case baseline of
 589                 Just base | result_ok base
 590                    -> map (\(r,s) -> percentage  r s base) rts'
 591                 _other
 592                    -> map (\(r,s) -> just_result r s) rts'
 593            )))
 594  where
 595         baseline  = get_maybe_a base_r
 596         base_stat = get_stat base_r
 597
 598         just_result Nothing  s = RunFailed s
 599         just_result (Just a) _ = toBox a
 600
 601         percentage Nothing   s _    = RunFailed s
 602         percentage (Just a)  _ base = Percentage
 603                                          (convert_to_percentage base a)
 604 -----------------------------------------------------------------------------
 605 -- Calculating geometric means and standard deviations
 606
 607 {-
 608 This is done using the log method, to avoid needing really large
 609 intermediate results.  The formula for a geometric mean is
 610
 611         (a1 * .... * an) ^ 1/n
 612
 613 which is equivalent to
 614
 615         e ^ ( (log a1 + ... + log an) / n )
 616
 617 where log is the natural logarithm function.
 618
 619 Similarly, to compute the geometric standard deviation we compute the
 620 deviation of each log, take the root-mean-square, and take the
 621 exponential again:
 622
 623         e ^ sqrt( ( sqr(log a1 - lbar) + ... + sqr(log an - lbar) ) / n )
 624
 625 where lbar is the mean log,
 626
 627         (log a1 + ... + log an) / n
 628
 629 This is a *factor*: i.e., the 1 s.d. points are (gm/sdf,gm*sdf); do
 630 not subtract 100 from gm before performing this calculation.
 631
 632 We therefore return a (low, mean, high) triple.
 633
 634 -}
 635
 636 calc_gmsd :: [BoxValue] -> (BoxValue, BoxValue, BoxValue)
 637 calc_gmsd xs
 638   | null percentages = (RunFailed NotDone, RunFailed NotDone, RunFailed NotDone)
 639   | otherwise        = let sqr x   = x * x
 640                            len     = fromIntegral (length percentages)
 641                            logs    = map log percentages
 642                            lbar    = sum logs / len
 643                            st_devs = map (sqr . (lbar-)) logs
 644                            dbar    = sum st_devs / len
 645                            gm      = exp lbar
 646                            sdf     = exp (sqrt dbar)
 647                        in
 648                        (Percentage (gm/sdf),
 649                         Percentage gm,
 650                         Percentage (gm*sdf))
 651  where
 652   percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]
 653         -- can't do log(0.0), so exclude zeros
 654         -- small values have inordinate effects so cap at -95%.
 655
 656 calc_minmax :: [BoxValue] -> (BoxValue, BoxValue)
 657 calc_minmax xs
 658  | null percentages = (RunFailed NotDone, RunFailed NotDone)
 659  | otherwise = (Percentage (minimum percentages),
 660                 Percentage (maximum percentages))
 661  where
 662   percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]
 663
 664
 665 -----------------------------------------------------------------------------
 666 -- Show the Results
 667
 668 class Num a => Result a where
 669         toBox :: a -> BoxValue
 670         convert_to_percentage :: a -> a -> Float
 671
 672 -- We assume an Int is a size, and print it in kilobytes.
 673
 674 instance Result Int where
 675     convert_to_percentage 0    _    = 100
 676     convert_to_percentage base size
 677         = (fromIntegral size / fromIntegral base) * 100
 678
 679     toBox = BoxInt
 680
 681 instance Result Integer where
 682     convert_to_percentage 0    _    = 100
 683     convert_to_percentage base size
 684         = (fromInteger size / fromInteger base) * 100
 685     toBox = BoxInteger
 686
 687 instance Result Float where
 688     convert_to_percentage 0.0  _    = 100.0
 689     convert_to_percentage base size = size / base * 100
 690
 691     toBox = BoxFloat
 692
 693 -- -----------------------------------------------------------------------------
 694 -- BoxValues
 695
 696 -- The contents of a box in a table
 697 data BoxValue
 698   = RunFailed Status
 699   | Percentage Float
 700   | BoxFloat Float
 701   | BoxInt Int
 702   | BoxInteger Integer
 703   | BoxString String
 704
 705 showBox :: BoxValue -> String
 706 showBox (RunFailed stat) = show_stat stat
 707 showBox (Percentage f)   = printf "%+.1f%%" (f-100)
 708 showBox (BoxFloat f)     = printf "%.2f" f
 709 showBox (BoxInt n)       = show (n `div` 1024) ++ "k"
 710 showBox (BoxInteger n)   = show (n `div` 1024) ++ "k"
 711 showBox (BoxString s)    = s
 712
 713 instance Show BoxValue where
 714     show = showBox
 715
 716 show_stat :: Status -> String
 717 show_stat Success     = "(no result)"
 718 show_stat WrongStdout = "(stdout)"
 719 show_stat WrongStderr = "(stderr)"
 720 show_stat (Exit x)    = "exit(" ++ show x ++")"
 721 show_stat OutOfHeap   = "(heap)"
 722 show_stat OutOfStack  = "(stack)"
 723 show_stat NotDone     = "-----"
 724
 725 -- -----------------------------------------------------------------------------
 726 -- Table layout
 727
 728 data TableRow
 729   = TableRow [BoxValue]
 730   | TableLine
 731
 732 type Layout = [String -> ShowS]
 733
 734 makeTable :: Layout -> [TableRow] -> ShowS
 735 makeTable layout = interleave "\n" . map do_row
 736   where do_row (TableRow boxes) = applyLayout layout boxes
 737         do_row TableLine = str (take 80 (repeat '-'))
 738
 739 makeLatexTable :: [TableRow] -> ShowS
 740 makeLatexTable = foldr (.) id . map do_row
 741   where do_row (TableRow boxes)
 742            = applyLayout latexTableLayout boxes . str "\\\\\n"
 743         do_row TableLine
 744            = str "\\hline\n"
 745
 746 latexTableLayout :: Layout
 747 latexTableLayout = box : repeat (box . (" & "++))
 748   where box s = str (foldr transchar "" s)
 749
 750         transchar '%' s = s  -- leave out the percentage signs
 751         transchar c   s = c : s
 752
 753 applyLayout :: Layout -> [BoxValue] -> ShowS
 754 applyLayout layout values =
 755  foldr (.) id [ f (show val) | (val,f) <- zip values layout ]
 756
 757 -- -----------------------------------------------------------------------------
 758 -- General Utils
 759
 760 split :: Char -> String -> [String]
 761 split c s = case rest of
 762                 []     -> [chunk]
 763                 _:rest -> chunk : split c rest
 764   where (chunk, rest) = break (==c) s
 765
 766 str :: String -> ShowS
 767 str = showString
 768
 769 interleave :: String -> [ShowS] -> ShowS
 770 interleave s = foldr1 (\a b -> a . str s . b)
 771
 772 fIELD_WIDTH :: Int
 773 fIELD_WIDTH = 16
 774
 775 -----------------------------------------------------------------------------