glafp-utils/nofib-analyse/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.8 2002/09/18 12:36:39 simonmar Exp $
   3
   4 -- (c) Simon Marlow 1997-1999
   5 -----------------------------------------------------------------------------
   6
   7 module Main where
   8
   9 import GenUtils
  10 import Printf
  11 import Slurp
  12 import CmdLine
  13
  14 import Html hiding ((!))
  15 import qualified Html ((!))
  16 import GlaExts
  17 import FiniteMap
  18 import GetOpt
  19
  20 import Char
  21 import IO
  22 import Array
  23 import System
  24 import List
  25
  26 (<!) = (Html.!)
  27
  28 -----------------------------------------------------------------------------
  29 -- Top level stuff
  30
  31 die :: String -> IO a
  32 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
  33
  34 usageHeader = "usage: nofib-analyse [OPTION...] <logfile1> <logfile2> ..."
  35
  36 main = do
  37
  38  if not (null cmdline_errors) || OptHelp `elem` flags
  39         then die (concat cmdline_errors ++ usageInfo usageHeader argInfo)
  40         else do
  41
  42  let { html  = OptHTMLOutput  `elem` flags;
  43        ascii = OptASCIIOutput `elem` flags
  44      }
  45
  46  if ascii && html
  47         then die "Can't produce both ASCII and HTML"
  48         else do
  49
  50  if devs && nodevs
  51         then die "Can't both display and hide deviations"
  52         else do
  53
  54  results <- parse_logs other_args
  55
  56  let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args
  57
  58  if html
  59         then putStr (renderHtml (htmlPage results column_headings))
  60         else putStr (asciiPage results column_headings)
  61
  62
  63 parse_logs :: [String] -> IO [ResultTable]
  64 parse_logs [] = do
  65         f <- hGetContents stdin
  66         return [parse_log f]
  67 parse_logs log_files =
  68         mapM (\f -> do h <- openFile f ReadMode
  69                        c <- hGetContents h
  70                        return (parse_log c)) log_files
  71
  72 -----------------------------------------------------------------------------
  73 -- List of tables we're going to generate
  74
  75 data PerProgTableSpec =
  76         forall a . Result a =>
  77            SpecP
  78                 String                  -- Name of the table
  79                 String                  -- HTML tag for the table
  80                 (Results -> Maybe a)    -- How to get the result
  81                 (Results -> Status)     -- How to get the status of this result
  82                 (a -> Bool)             -- Result within reasonable limits?
  83
  84 data PerModuleTableSpec =
  85         forall a . Result a =>
  86            SpecM
  87                 String                  -- Name of the table
  88                 String                  -- HTML tag for the table
  89                 (Results -> FiniteMap String a) -- get the module map
  90                 (a -> Bool)             -- Result within reasonable limits?
  91
  92 per_prog_result_tab =
  93         [ SpecP "Binary Sizes" "binary-sizes" binary_size compile_status always_ok
  94         , SpecP "Allocations" "allocations" allocs run_status always_ok
  95         , SpecP "Run Time" "run-times" run_time run_status time_ok
  96         , SpecP "Mutator Time" "mutator-time" mut_time run_status time_ok
  97         , SpecP "GC Time" "gc-time" gc_time run_status time_ok
  98         , SpecP "GC Work" "gc-work" gc_work run_status always_ok
  99         , SpecP "Instructions" "instrs" instrs run_status always_ok
 100         , SpecP "Memory Reads" "mem-reads" mem_reads run_status always_ok
 101         , SpecP "Memory Writes" "mem-writes" mem_writes run_status always_ok
 102         , SpecP "Cache Misses" "cache-misses" cache_misses run_status always_ok
 103         ]
 104
 105 per_module_result_tab =
 106         [ SpecM "Module Sizes"  "mod-sizes"     module_size  always_ok
 107         , SpecM "Compile Times" "compile-time"  compile_time time_ok
 108         ]
 109
 110 always_ok :: a -> Bool
 111 always_ok = const True
 112
 113 time_ok :: Float -> Bool
 114 time_ok t = t > tooquick_threshold
 115
 116 -----------------------------------------------------------------------------
 117 -- HTML page generation
 118
 119 --htmlPage :: Results -> [String] -> Html
 120 htmlPage results args
 121    =  header << thetitle << reportTitle
 122           +++ hr
 123           +++ h1 << reportTitle
 124           +++ gen_menu
 125           +++ hr
 126           +++ body (gen_tables results args)
 127
 128 gen_menu = unordList (map (prog_menu_item) per_prog_result_tab
 129                       ++ map (module_menu_item) per_module_result_tab)
 130
 131 prog_menu_item (SpecP name anc _ _ _) = anchor <! [href ('#':anc)] << name
 132 module_menu_item (SpecM name anc _ _) = anchor <! [href ('#':anc)] << name
 133
 134 gen_tables results args =
 135   foldr1 (+++) (map (htmlGenProgTable results args) per_prog_result_tab)
 136   +++ foldr1 (+++) (map (htmlGenModTable results args) per_module_result_tab)
 137
 138 htmlGenProgTable results args (SpecP title anc get_result get_status result_ok)
 139   =   sectHeading title anc
 140   +++ font <! [size "1"]
 141         << mkTable (htmlShowResults results args get_result get_status result_ok)
 142   +++ hr
 143
 144 htmlGenModTable results args (SpecM title anc get_result result_ok)
 145   =   sectHeading title anc
 146   +++ font <![size "1"]
 147         << mkTable (htmlShowMultiResults results args get_result result_ok)
 148   +++ hr
 149
 150 sectHeading :: String -> String -> Html
 151 sectHeading s nm = h2 << anchor <! [name nm] << s
 152
 153 htmlShowResults
 154     :: Result a
 155         => [ResultTable]
 156         -> [String]
 157         -> (Results -> Maybe a)
 158         -> (Results -> Status)
 159         -> (a -> Bool)
 160         -> HtmlTable
 161
 162 htmlShowResults (r:rs) ss f stat result_ok
 163   =   tabHeader ss
 164   </> aboves (zipWith tableRow [1..] results_per_prog)
 165   </> aboves ((if nodevs then []
 166                          else [tableRow (-1) ("-1 s.d.", lows),
 167                                tableRow (-1) ("+1 s.d.", highs)])
 168                     ++ [tableRow (-1) ("Average", gms)])
 169  where
 170         -- results_per_prog :: [ (String,[BoxValue a]) ]
 171         results_per_prog = map (calc_result rs f stat result_ok) (fmToList r)
 172
 173         results_per_run  = transpose (map snd results_per_prog)
 174         (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
 175
 176 htmlShowMultiResults
 177     :: Result a
 178         => [ResultTable]
 179         -> [String]
 180         -> (Results -> FiniteMap String a)
 181         -> (a -> Bool)
 182         -> HtmlTable
 183
 184 htmlShowMultiResults (r:rs) ss f result_ok =
 185         multiTabHeader ss
 186          </> aboves (map show_results_for_prog results_per_prog_mod_run)
 187          </> aboves ((if nodevs then []
 188                                       else [td << bold << "-1 s.d."
 189                                             <-> tableRow (-1) ("", lows),
 190                                             td << bold << "+1 s.d."
 191                                             <-> tableRow (-1) ("", highs)])
 192                            ++ [td << bold << "Average"
 193                                <-> tableRow (-1) ("", gms)])
 194
 195   where
 196         base_results = fmToList r :: [(String,Results)]
 197
 198         -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
 199         results_per_prog_mod_run = map get_results_for_prog base_results
 200
 201         -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
 202         get_results_for_prog (prog,r) = (prog, map get_results_for_mod (fmToList (f r)))
 203
 204            where fms = map get_run_results rs
 205
 206                  get_run_results fm = case lookupFM fm prog of
 207                                         Nothing  -> emptyFM
 208                                         Just res -> f res
 209
 210                  get_results_for_mod (id,attr) = calc_result fms Just (const Success)
 211                                                              result_ok (id,attr)
 212
 213         show_results_for_prog (prog,mrs) =
 214             td <! [valign "top"] << bold << prog
 215             <-> (if null mrs then
 216                    td << "(no modules compiled)"
 217                  else
 218                    toHtml (aboves (map (tableRow 0) mrs)))
 219
 220         results_per_run  = transpose [xs | (_,mods) <- results_per_prog_mod_run,
 221                                            (_,xs) <- mods]
 222         (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
 223
 224 tableRow :: Result a => Int -> (String, [BoxValue a]) -> HtmlTable
 225 tableRow row_no (prog, results)
 226         =   td <! [bgcolor left_column_color] << prog
 227         <-> besides (map (\s -> td <! [align "right", clr] << show_box s)
 228                                 results)
 229   where clr | row_no < 0  = bgcolor average_row_color
 230             | even row_no = bgcolor even_row_color
 231             | otherwise   = bgcolor odd_row_color
 232
 233 left_column_color = "#d0d0ff"  -- light blue
 234 odd_row_color     = "#d0d0ff"  -- light blue
 235 even_row_color    = "#f0f0ff"  -- v. light blue
 236 average_row_color = "#ffd0d0"  -- light red
 237
 238 {-
 239 findBest :: Result a => [BoxValue a] -> [(Bool,BoxValue a)]
 240 findBest stuff@(Result base : rest)
 241   = map (\a -> (a==base, a))
 242   where
 243         best = snd (minimumBy (\a b -> fst a < fst b) no_pcnt_stuff
 244
 245         no_pcnt_stuff = map unPcnt stuff
 246
 247         unPcnt (r@(Percentage f) : rest) = (base * f/100, r) : unPcnt rest
 248         unPcnt (r@(Result a) : rest)     = (a, r) : unPcnt rest
 249         unPcnt (_ : rest)                = unPcnt rest
 250 -}
 251
 252 logHeaders ss
 253   = besides (map (\s -> (td <! [align "right", width "100"] << bold << s)) ss)
 254
 255 mkTable t = table <! [cellspacing 0, cellpadding 0, border 0] << t
 256
 257 tabHeader ss
 258   =   (td <! [align "left", width "100"] << bold << "Program")
 259   <-> logHeaders ss
 260
 261 multiTabHeader ss
 262   =   (td <! [align "left", width "100"] << bold << "Program")
 263   <-> (td <! [align "left", width "100"] << bold << "Module")
 264   <-> logHeaders ss
 265
 266 -- Calculate a color ranging from bright blue for -100% to bright red for +100%.
 267
 268 calcColor :: Int -> String
 269 calcColor p | p >= 0    = "#"     ++ (showHex red 2 "0000")
 270               | otherwise = "#0000" ++ (showHex blue 2 "")
 271         where red  = p * 255 `div` 100
 272               blue = (-p) * 255 `div` 100
 273
 274 showHex 0 f s = if f > 0 then take f (repeat '0') ++ s else s
 275 showHex i f s = showHex (i `div` 16) (f-1) (hexDig (i `mod` 16) : s)
 276
 277 hexDig i | i > 10 = chr (i-10 + ord 'a')
 278          | otherwise = chr (i + ord '0')
 279
 280 -----------------------------------------------------------------------------
 281 -- ASCII page generation
 282
 283 asciiPage results args =
 284   ( str reportTitle
 285   . str "\n\n"
 286   . interleave "\n\n" (map (asciiGenProgTable results args) per_prog_result_tab)
 287   . str "\n"
 288   . interleave "\n\n" (map (asciiGenModTable results args)  per_module_result_tab)
 289   ) "\n"
 290
 291 asciiGenProgTable results args (SpecP title anc get_result get_status result_ok)
 292   = str title
 293   . str "\n"
 294   . ascii_show_results results args get_result get_status result_ok
 295
 296 asciiGenModTable results args (SpecM title anc get_result result_ok)
 297   = str title
 298   . str "\n"
 299   . ascii_show_multi_results results args get_result result_ok
 300
 301 ascii_header ss
 302         = str "\n-------------------------------------------------------------------------------\n"
 303         . str (rjustify 15 "Program")
 304         . str (space 5)
 305         . foldr (.) id (map (str . rjustify fIELD_WIDTH) ss)
 306         . str "\n-------------------------------------------------------------------------------\n"
 307
 308 ascii_show_results
 309    :: Result a
 310         => [ResultTable]
 311         -> [String]
 312         -> (Results -> Maybe a)
 313         -> (Results -> Status)
 314         -> (a -> Bool)
 315         -> ShowS
 316
 317 ascii_show_results (r:rs) ss f stat result_ok
 318         = ascii_header ss
 319         . interleave "\n" (map show_per_prog_results results_per_prog)
 320         . if nodevs then id
 321                     else   str "\n"
 322                          . show_per_prog_results ("-1 s.d.",lows)
 323                          . str "\n"
 324                          . show_per_prog_results ("+1 s.d.",highs)
 325         . str "\n"
 326         . show_per_prog_results ("Average",gms)
 327  where
 328         -- results_per_prog :: [ (String,[BoxValue a]) ]
 329         results_per_prog = map (calc_result rs f stat result_ok) (fmToList r)
 330
 331         results_per_run  = transpose (map snd results_per_prog)
 332         (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
 333
 334 ascii_show_multi_results
 335    :: Result a
 336         => [ResultTable]
 337         -> [String]
 338         -> (Results -> FiniteMap String a)
 339         -> (a -> Bool)
 340         -> ShowS
 341
 342 ascii_show_multi_results (r:rs) ss f result_ok
 343         = ascii_header ss
 344         . interleave "\n" (map show_results_for_prog results_per_prog_mod_run)
 345         . str "\n"
 346         . if nodevs then id
 347                     else   str "\n"
 348                          . show_per_prog_results ("-1 s.d.",lows)
 349                          . str "\n"
 350                          . show_per_prog_results ("+1 s.d.",highs)
 351         . str "\n"
 352         . show_per_prog_results ("Average",gms)
 353   where
 354         base_results = fmToList r :: [(String,Results)]
 355
 356         -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])]
 357         results_per_prog_mod_run = map get_results_for_prog base_results
 358
 359         -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a])
 360         get_results_for_prog (prog,r) = (prog, map get_results_for_mod (fmToList (f r)))
 361
 362            where fms = map get_run_results rs
 363
 364                  get_run_results fm = case lookupFM fm prog of
 365                                         Nothing  -> emptyFM
 366                                         Just res -> f res
 367
 368                  get_results_for_mod (id,attr) = calc_result fms Just (const Success)
 369                                                              result_ok (id,attr)
 370
 371         show_results_for_prog (prog,mrs) =
 372               str ("\n"++prog++"\n")
 373             . (if null mrs then
 374                    str "(no modules compiled)\n"
 375                  else
 376                    interleave "\n" (map show_per_prog_results mrs))
 377
 378         results_per_run  = transpose [xs | (_,mods) <- results_per_prog_mod_run,
 379                                            (_,xs) <- mods]
 380         (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run)
 381
 382 show_per_prog_results :: Result a => (String, [BoxValue a]) -> ShowS
 383 show_per_prog_results (prog,results)
 384         = str (rjustify 15 prog)
 385         . str (space 5)
 386         . foldr (.) id (map (str . rjustify fIELD_WIDTH . show_box) results)
 387
 388 -----------------------------------------------------------------------------
 389 -- Show the Results
 390
 391 class Num a => Result a where
 392         result_to_string :: a -> String
 393         convert_to_percentage :: a -> a -> Float
 394
 395 -- We assume an Int is a size, and print it in kilobytes.
 396
 397 instance Result Int where
 398         convert_to_percentage 0 size = 100
 399         convert_to_percentage base size = (fromIntegral size / fromIntegral base) * 100
 400
 401         result_to_string n = show (n `div` 1024) ++ "k"
 402
 403 instance Result Integer where
 404         convert_to_percentage 0 size = 100
 405         convert_to_percentage base size = (fromInteger size / fromInteger base) * 100
 406
 407         result_to_string n = show (n `quot` 1024) ++ "k"
 408
 409 instance Result Float where
 410         convert_to_percentage 0.0 size = 100.0
 411         convert_to_percentage base size = size / base * 100
 412
 413         result_to_string = showFloat' Nothing (Just 2)
 414
 415 data BoxValue a = RunFailed Status | Percentage Float | Result a
 416
 417 -- calc_result is a nice exercise in higher-order programming...
 418 calc_result
 419   :: Result a
 420         => [FiniteMap String b]         -- accumulated results
 421         -> (b -> Maybe a)               -- get a result from the b
 422         -> (b -> Status)                -- get a status from the b
 423         -> (a -> Bool)                  -- is this result ok?
 424         -> (String,b)                   -- the baseline result
 425         -> (String,[BoxValue a])
 426
 427 calc_result rts get_maybe_a get_stat result_ok (prog,base_r) =
 428         (prog, (just_result baseline base_stat :
 429
 430           let
 431                 rts' = map (\rt -> get_stuff (lookupFM rt prog)) rts
 432
 433                 get_stuff Nothing  = (Nothing, NotDone)
 434                 get_stuff (Just r) = (get_maybe_a r, get_stat r)
 435           in
 436           (
 437           case baseline of
 438                 Just base | result_ok base
 439                    -> map (\(r,s) -> percentage  r s base) rts'
 440                 _other
 441                    -> map (\(r,s) -> just_result r s) rts'
 442            )))
 443  where
 444         baseline  = get_maybe_a base_r
 445         base_stat = get_stat base_r
 446
 447         just_result Nothing  s = RunFailed s
 448         just_result (Just a) s = Result a
 449
 450         percentage Nothing   s base = RunFailed s
 451         percentage (Just a)  s base = Percentage
 452                                          (convert_to_percentage base a)
 453 show_box (RunFailed s)  = show_stat s
 454 show_box (Percentage p) = show_pcntage p
 455 show_box (Result a)     = result_to_string a
 456
 457 -----------------------------------------------------------------------------
 458 -- Calculating geometric means and standard deviations
 459
 460 {-
 461 This is done using the log method, to avoid needing really large
 462 intermediate results.  The formula for a geometric mean is
 463
 464         (a1 * .... * an) ^ 1/n
 465
 466 which is equivalent to
 467
 468         e ^ ( (log a1 + ... + log an) / n )
 469
 470 where log is the natural logarithm function.
 471
 472 Similarly, to compute the geometric standard deviation we compute the
 473 deviation of each log, take the root-mean-square, and take the
 474 exponential again:
 475
 476         e ^ sqrt( ( sqr(log a1 - lbar) + ... + sqr(log an - lbar) ) / n )
 477
 478 where lbar is the mean log,
 479
 480         (log a1 + ... + log an) / n
 481
 482 This is a *factor*: i.e., the 1 s.d. points are (gm/sdf,gm*sdf); do
 483 not subtract 100 from gm before performing this calculation.
 484
 485 We therefore return a (low, mean, high) triple.
 486
 487 -}
 488
 489 calc_gmsd :: [BoxValue a] -> (BoxValue Float, BoxValue Float, BoxValue Float)
 490 calc_gmsd xs
 491   | null percentages = (RunFailed NotDone, RunFailed NotDone, RunFailed NotDone)
 492   | otherwise        = let sqr x = x * x
 493                            len   = fromIntegral (length percentages)
 494                            logs  = map log percentages
 495                            lbar  = sum logs / len
 496                            devs  = map (sqr . (lbar-)) logs
 497                            dbar  = sum devs / len
 498                            gm    = exp lbar
 499                            sdf   = exp (sqrt dbar)
 500                        in
 501                        (Percentage (gm/sdf),
 502                         Percentage gm,
 503                         Percentage (gm*sdf))
 504  where
 505   percentages = [ if f < 5 then 5 else f | Percentage f <- xs ]
 506         -- can't do log(0.0), so exclude zeros
 507         -- small values have inordinate effects so cap at -95%.
 508
 509 -----------------------------------------------------------------------------
 510 -- Generic stuff for results generation
 511
 512 show_pcntage n = show_float_signed (n-100) ++ "%"
 513
 514 show_float_signed = showFloat False False True False False Nothing (Just 2)
 515
 516 show_stat Success     = "(no result)"
 517 show_stat WrongStdout = "(stdout)"
 518 show_stat WrongStderr = "(stderr)"
 519 show_stat (Exit x)    = "exit(" ++ show x ++")"
 520 show_stat OutOfHeap   = "(heap)"
 521 show_stat OutOfStack  = "(stack)"
 522 show_stat NotDone     = "-----"
 523
 524 str = showString
 525
 526 interleave s = foldr1 (\a b -> a . str s . b)
 527
 528 fIELD_WIDTH = 16 :: Int
 529
 530 -----------------------------------------------------------------------------