glafp-utils/nofib-analyse/Main.hs

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