1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.1 1999/11/12 11:54:17 simonmar Exp $
4 -- (c) Simon Marlow 1997-1999
5 -----------------------------------------------------------------------------
25 -----------------------------------------------------------------------------
29 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
31 usageHeader = "usage: nofib-analyse [OPTION...] <logfile1> <logfile2> ..."
35 if not (null cmdline_errors) || OptHelp `elem` flags
36 then die (concat cmdline_errors ++ usageInfo usageHeader argInfo)
39 let { html = OptHTMLOutput `elem` flags;
40 ascii = OptASCIIOutput `elem` flags
44 then die "Can't produce both ASCII and HTML"
47 results <- parse_logs other_args
49 let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args
52 then putStr (renderHtml (htmlPage results column_headings))
53 else putStr (asciiPage results column_headings)
56 parse_logs :: [String] -> IO [ResultTable]
58 f <- hGetContents stdin
60 parse_logs log_files =
61 mapM (\f -> do h <- openFile f ReadMode
63 return (parse_log c)) log_files
65 -----------------------------------------------------------------------------
66 -- List of tables we're going to generate
68 data PerProgTableSpec =
69 forall a . Result a =>
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?
77 data PerModuleTableSpec =
78 forall a . Result a =>
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?
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
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
102 always_ok :: a -> Bool
103 always_ok = const True
105 time_ok :: Float -> Bool
106 time_ok t = t > tooquick_threshold
108 -----------------------------------------------------------------------------
109 -- HTML page generation
111 htmlPage results args
112 = header [] (theTitle [] (htmlStr "NoFib Results"))
116 +++ body [] (gen_tables results args)
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)))
122 prog_menu_item (SpecP name anc _ _ _) = anchor [href ('#':anc)] (htmlStr name)
123 module_menu_item (SpecM name anc _ _) = anchor [href ('#':anc)] (htmlStr name)
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)
129 htmlGenProgTable results args (SpecP title anc get_result get_status result_ok)
130 = sectHeading title anc
132 mkTable (htmlShowResults results args get_result get_status result_ok))
135 htmlGenModTable results args (SpecM title anc get_result result_ok)
136 = sectHeading title anc
138 mkTable (htmlShowMultiResults results args get_result result_ok))
141 sectHeading :: String -> String -> Html
143 = h2 [] (anchor [name nm] (htmlStr s))
149 -> (Results -> Maybe a)
150 -> (Results -> Status)
154 htmlShowResults (r:rs) ss f stat result_ok
156 +/+ foldr1 (+/+) (zipWith tableRow [1..] results_per_prog)
157 +/+ tableRow (-1) ("Average", geometric_means)
159 -- results_per_prog :: [ (String,[BoxValue a]) ]
160 results_per_prog = map (calc_result rs f stat result_ok) (fmToList r)
162 results_per_run = transpose (map snd results_per_prog)
163 geometric_means = map calc_gm results_per_run
169 -> (Results -> FiniteMap String a)
173 htmlShowMultiResults (r:rs) ss f result_ok =
175 +/+ foldr1 (+/+) (map show_results_for_prog base_results)
178 base_results = fmToList r :: [(String,Results)]
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)")
185 foldr1 (+/+) (map (show_one_result fms) base))
188 base = fmToList (f r)
189 fms = map (get_results_for prog) rs
191 get_results_for prog m = case lookupFM m prog of
195 show_one_result other_results (id,attribute) =
197 calc_result other_results Just (const Success)
198 result_ok (id,attribute)
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
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
216 findBest :: Result a => [BoxValue a] -> [(Bool,BoxValue a)]
217 findBest stuff@(Result base : rest)
218 = map (\a -> (a==base, a))
220 best = snd (minimumBy (\a b -> fst a < fst b) no_pcnt_stuff
222 no_pcnt_stuff = map unPcnt stuff
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
230 = foldr1 (+-+) (map (\s -> cellHtml [align "right", width "100"]
231 (bold [] (htmlStr s))) ss)
233 mkTable :: HtmlTable -> Html
234 mkTable = renderTable [cellspacing 0, cellpadding 0, border 0]
237 = cellHtml [align "left", width "100"] (bold [] (htmlStr "Program"))
241 = cellHtml [align "left", width "100"] (bold [] (htmlStr "Program"))
242 +-+ cellHtml [align "left", width "100"] (bold [] (htmlStr "Module"))
245 -- Calculate a color ranging from bright blue for -100% to bright red for +100%.
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
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)
256 hexDig i | i > 10 = chr (i-10 + ord 'a')
257 | otherwise = chr (i + ord '0')
259 -----------------------------------------------------------------------------
260 -- ASCII page generation
262 asciiPage results args =
263 ( interleave "\n\n" (map (asciiGenProgTable results args) per_prog_result_tab)
265 . interleave "\n\n" (map (asciiGenModTable results args) per_module_result_tab)
268 asciiGenProgTable results args (SpecP title anc get_result get_status result_ok)
271 . ascii_show_results results args get_result get_status result_ok
273 asciiGenModTable results args (SpecM title anc get_result result_ok)
276 . ascii_show_multi_results results args get_result result_ok
279 = str "\n-------------------------------------------------------------------------------\n"
280 . str (rjustify 15 "Program")
282 . foldr (.) id (map (str . rjustify fIELD_WIDTH) ss)
283 . str "\n-------------------------------------------------------------------------------\n"
289 -> (Results -> Maybe a)
290 -> (Results -> Status)
294 ascii_show_results (r:rs) ss f stat result_ok
296 . interleave "\n" (map show_per_prog_results results_per_prog)
298 . show_per_prog_results ("Average",geometric_means)
300 -- results_per_prog :: [ (String,[BoxValue a]) ]
301 results_per_prog = map (calc_result rs f stat result_ok) (fmToList r)
303 results_per_run = transpose (map snd results_per_prog)
304 geometric_means = map calc_gm results_per_run
306 ascii_show_multi_results
310 -> (Results -> FiniteMap String a)
314 ascii_show_multi_results (r:rs) ss f result_ok
316 . interleave "\n" (map show_results_for_prog base_results)
318 base_results = fmToList r :: [(String,Results)]
320 show_results_for_prog (prog,r) =
321 str ("\n"++prog++"\n")
323 str "(no modules compiled)\n"
325 interleave "\n" (map (show_one_result fms) base))
328 base = fmToList (f r)
329 fms = map (get_results_for prog) rs
331 get_results_for prog m = case lookupFM m prog of
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)
341 show_per_prog_results :: Result a => (String, [BoxValue a]) -> ShowS
342 show_per_prog_results (prog,results)
343 = str (rjustify 15 prog)
345 . foldr (.) id (map (str . rjustify fIELD_WIDTH . show_box) results)
347 -----------------------------------------------------------------------------
350 class Num a => Result a where
351 result_to_string :: a -> String
352 convert_to_percentage :: a -> a -> Float
354 -- We assume an Int is a size, and print it in kilobytes.
356 instance Result Int where
357 convert_to_percentage 0 size = 100
358 convert_to_percentage base size = (fromInt size / fromInt base) * 100
360 result_to_string n = show (n `div` 1024) ++ "k"
362 instance Result Integer where
363 convert_to_percentage 0 size = 100
364 convert_to_percentage base size = (fromInteger size / fromInteger base) * 100
366 result_to_string n = show (n `quot` 1024) ++ "k"
368 instance Result Float where
369 convert_to_percentage 0.0 size = 100.0
370 convert_to_percentage base size = size / base * 100
372 result_to_string = showFloat' Nothing (Just 2)
374 data BoxValue a = RunFailed Status | Percentage Float | Result a
376 -- calc_result is a nice exercise in higher-order programming...
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])
386 calc_result rts get_maybe_a get_stat result_ok (prog,base_r) =
387 (prog, (just_result baseline base_stat :
390 rts' = map (\rt -> get_stuff (lookupFM rt prog)) rts
392 get_stuff Nothing = (Nothing, NotDone)
393 get_stuff (Just r) = (get_maybe_a r, get_stat r)
397 Just base | result_ok base
398 -> map (\(r,s) -> percentage r s base) rts'
400 -> map (\(r,s) -> just_result r s) rts'
403 baseline = get_maybe_a base_r
404 base_stat = get_stat base_r
406 just_result Nothing s = RunFailed s
407 just_result (Just a) s = Result a
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
416 -----------------------------------------------------------------------------
417 -- Calculating geometric means
420 This is done using the log method, to avoid needing really large
421 intermediate results. The formula for a geometric mean is
423 (a1 * .... * an) ^ 1/n
425 which is equivalent to
427 e ^ ( (log a1 + ... + log an) / n )
429 where log is the natural logarithm function.
432 calc_gm :: [BoxValue a] -> BoxValue Float
434 | null percentages = RunFailed NotDone
435 | otherwise = Percentage (exp (sum (map log percentages) /
436 fromInt (length percentages)))
438 percentages = [ f | Percentage f <- xs, f /= 0.0 ]
439 -- can't do log(0.0), so exclude zeros
441 -----------------------------------------------------------------------------
442 -- Generic stuff for results generation
444 show_pcntage n = show_float_signed (n-100) ++ "%"
446 show_float_signed = showFloat False False True False False Nothing (Just 2)
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 = "-----"
458 interleave s = foldr1 (\a b -> a . str s . b)
460 fIELD_WIDTH = 16 :: Int
462 -----------------------------------------------------------------------------