glafp-utils/nofib-analyse/Main.hs

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