glafp-utils/nofib-analyse/Main.hs

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