----------------------------------------------------------------------------- -- $Id: Main.hs,v 1.10 2005/06/07 10:58:31 simonmar Exp $ -- (c) Simon Marlow 1997-2005 ----------------------------------------------------------------------------- module Main where import GenUtils import Slurp import CmdLine import Text.Printf import Text.Html hiding (cols, rows, (!)) import qualified Text.Html as Html ((!)) import qualified Data.Map as Map import Data.Map (Map) import System.Exit ( exitWith, ExitCode(..) ) import Control.Monad import Data.Maybe ( isNothing ) import System.IO import Data.List ( a -> [HtmlAttr] -> a ( IO a die s = hPutStr stderr s >> exitWith (ExitFailure 1) data Normalise = NormalisePercent | NormaliseRatio | NormaliseNone main :: IO () main = do when (not (null cmdline_errors) || OptHelp `elem` flags) $ die (concat cmdline_errors ++ usage) norm <- case [ n | OptNormalise n <- flags ] of [] -> return NormalisePercent ["percent"] -> return NormalisePercent ["ratio"] -> return NormaliseRatio ["none"] -> return NormaliseNone _ -> die ("unrecognised value for --normalise\n" ++ usage) let { html = OptHTMLOutput `elem` flags; latex = [ t | OptLaTeXOutput t <- flags ]; ascii = OptASCIIOutput `elem` flags; csv = [ t | OptCSV t <- flags ]; } when (ascii && html) $ die "Can't produce both ASCII and HTML" when (devs && nodevs) $ die "Can't both display and hide deviations" results <- parse_logs other_args summary_spec <- case [ cols | OptColumns cols <- flags ] of [] -> return (pickSummary results) (cols:_) -> namedColumns (split ',' cols) let summary_rows = case [ rows | OptRows rows <- flags ] of [] -> Nothing rows -> Just (split ',' (last rows)) let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args -- sanity check sequence_ [ checkTimes prog res | result_table <- results, (prog,res) <- Map.toList result_table ] case () of _ | not (null csv) -> putStr (csvTable results (head csv) norm) _ | html -> putStr (renderHtml (htmlPage results column_headings)) _ | not (null latex) -> putStr (latexOutput results (head latex) column_headings summary_spec summary_rows norm) _ | otherwise -> putStr (asciiPage results column_headings summary_spec summary_rows norm) parse_logs :: [String] -> IO [ResultTable] parse_logs [] = do f <- hGetContents stdin return [parse_log f] parse_logs log_files = mapM (\f -> do h <- openFile f ReadMode c <- hGetContents h return (parse_log c)) log_files ----------------------------------------------------------------------------- -- List of tables we're going to generate data PerProgTableSpec = forall a . Result a => SpecP String -- Name of the table String -- Short name (for column heading) String -- HTML tag for the table (Results -> Maybe a) -- How to get the result (Results -> Status) -- How to get the status of this result (a -> Bool) -- Result within reasonable limits? data PerModuleTableSpec = forall a . Result a => SpecM String -- Name of the table String -- HTML tag for the table (Results -> Map String a) -- get the module map (a -> Bool) -- Result within reasonable limits? -- The various per-program aspects of execution that we can generate results for. size_spec, alloc_spec, runtime_spec, elapsedtime_spec, muttime_spec, mutetime_spec, gctime_spec, gcelap_spec, gcwork_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec, gc0time_spec, gc0elap_spec, gc1time_spec, gc1elap_spec, balance_spec, totmem_spec :: PerProgTableSpec size_spec = SpecP "Binary Sizes" "Size" "binary-sizes" binary_size compile_status always_ok alloc_spec = SpecP "Allocations" "Allocs" "allocations" allocs run_status always_ok runtime_spec = SpecP "Run Time" "Runtime" "run-times" (mean run_time) run_status time_ok elapsedtime_spec = SpecP "Elapsed Time" "Elapsed" "elapsed-times" (mean elapsed_time) run_status time_ok muttime_spec = SpecP "Mutator Time" "MutTime" "mutator-time" (mean mut_time) run_status time_ok mutetime_spec = SpecP "Mutator Elapsed Time" "MutETime" "mutator-elapsed-time" (mean mut_elapsed_time) run_status time_ok gctime_spec = SpecP "GC Time" "GCTime" "gc-time" (mean gc_time) run_status time_ok gcelap_spec = SpecP "GC Elapsed Time" "GCETime" "gc-elapsed-time" (mean gc_elapsed_time) run_status time_ok gc0time_spec = SpecP "GC(0) Time" "GC0Time" "gc0-time" (mean gc0_time) run_status time_ok gc0elap_spec = SpecP "GC(0) Elapsed Time" "GC0ETime" "gc0-elapsed-time" (mean gc0_elapsed_time) run_status time_ok gc1time_spec = SpecP "GC(1) Time" "GC1Time" "gc1-time" (mean gc1_time) run_status time_ok gc1elap_spec = SpecP "GC(1) Elapsed Time" "GC1ETime" "gc1-elapsed-time" (mean gc1_elapsed_time) run_status time_ok balance_spec = SpecP "GC work balance" "Balance" "balance" (mean balance) run_status time_ok gcwork_spec = SpecP "GC Work" "GCWork" "gc-work" gc_work run_status always_ok instrs_spec = SpecP "Instructions" "Instrs" "instrs" instrs run_status always_ok mreads_spec = SpecP "Memory Reads" "Reads" "mem-reads" mem_reads run_status always_ok mwrite_spec = SpecP "Memory Writes" "Writes" "mem-writes" mem_writes run_status always_ok cmiss_spec = SpecP "Cache Misses" "Misses" "cache-misses" cache_misses run_status always_ok totmem_spec = SpecP "Total Memory in use" "TotalMem" "total-mem" total_memory run_status always_ok all_specs :: [PerProgTableSpec] all_specs = [ size_spec, alloc_spec, runtime_spec, elapsedtime_spec, muttime_spec, mutetime_spec, gctime_spec, gcelap_spec, gc0time_spec, gc0elap_spec, gc1time_spec, gc1elap_spec, balance_spec, gcwork_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec, totmem_spec ] namedColumns :: [String] -> IO [PerProgTableSpec] namedColumns ss = mapM findSpec ss where findSpec s = case [ spec | spec@(SpecP _ short_name _ _ _ _) <- all_specs, short_name == s ] of [] -> die ("unknown column: " ++ s) (spec:_) -> return spec mean :: (Results -> [Float]) -> Results -> Maybe Float mean f results = go (f results) where go [] = Nothing go fs = Just (foldl' (+) 0 fs / fromIntegral (length fs)) -- Look for bogus-looking times: On Linux we occasionally get timing results -- that are bizarrely low, and skew the average. checkTimes :: String -> Results -> IO () checkTimes prog results = do check "run time" (run_time results) check "mut time" (mut_time results) check "GC time" (gc_time results) where check kind ts | any strange ts = hPutStrLn stderr ("warning: dubious " ++ kind ++ " results for " ++ prog ++ ": " ++ show ts) | otherwise = return () where strange t = any (\r -> time_ok r && r / t > 1.4) ts -- looks for times that are >40% smaller than -- any other. -- These are the per-prog tables we want to generate per_prog_result_tab :: [PerProgTableSpec] per_prog_result_tab = [ size_spec, alloc_spec, runtime_spec, elapsedtime_spec, muttime_spec, mutetime_spec, gctime_spec, gcelap_spec, gc0time_spec, gc0elap_spec, gc1time_spec, gc1elap_spec, gcwork_spec, balance_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec, totmem_spec] -- A single summary table, giving comparison figures for a number of -- aspects, each in its own column. Only works when comparing two runs. normal_summary_specs :: [PerProgTableSpec] normal_summary_specs = [ size_spec, alloc_spec, runtime_spec, elapsedtime_spec, totmem_spec ] cachegrind_summary_specs :: [PerProgTableSpec] cachegrind_summary_specs = [ size_spec, alloc_spec, instrs_spec, mreads_spec, mwrite_spec ] -- Pick an appropriate summary table: if we're cachegrinding, then -- we're probably not interested in the runtime, but we are interested -- in instructions, mem reads and mem writes (and vice-versa). pickSummary :: [ResultTable] -> [PerProgTableSpec] pickSummary rs | isNothing (instrs (head (Map.elems (head rs)))) = normal_summary_specs | otherwise = cachegrind_summary_specs per_module_result_tab :: [PerModuleTableSpec] per_module_result_tab = [ SpecM "Module Sizes" "mod-sizes" module_size always_ok , SpecM "Compile Times" "compile-time" compile_time time_ok ] always_ok :: a -> Bool always_ok = const True time_ok :: Float -> Bool time_ok t = t > tooquick_threshold ----------------------------------------------------------------------------- -- HTML page generation htmlPage :: [ResultTable] -> [String] -> Html htmlPage results args = header << thetitle << reportTitle +++ hr +++ h1 << reportTitle +++ gen_menu +++ hr +++ body (gen_tables results args) gen_menu :: Html gen_menu = unordList (map (prog_menu_item) per_prog_result_tab ++ map (module_menu_item) per_module_result_tab) prog_menu_item :: PerProgTableSpec -> Html prog_menu_item (SpecP long_name _ anc _ _ _) = anchor Html module_menu_item (SpecM long_name anc _ _) = anchor [String] -> Html gen_tables results args = foldr1 (+++) (map (htmlGenProgTable results args) per_prog_result_tab) +++ foldr1 (+++) (map (htmlGenModTable results args) per_module_result_tab) htmlGenProgTable :: [ResultTable] -> [String] -> PerProgTableSpec -> Html htmlGenProgTable results args (SpecP long_name _ anc get_result get_status result_ok) = sectHeading long_name anc +++ font [String] -> PerModuleTableSpec -> Html htmlGenModTable results args (SpecM long_name anc get_result result_ok) = sectHeading long_name anc +++ font String -> Html sectHeading s nm = h2 << anchor [ResultTable] -> [String] -> (Results -> Maybe a) -> (Results -> Status) -> (a -> Bool) -> HtmlTable htmlShowResults [] _ _ _ _ = error "htmlShowResults: Can't happen?" htmlShowResults (r:rs) ss f stat result_ok = tabHeader ss aboves (zipWith tableRow [1..] results_per_prog) aboves ((if nodevs then [] else [tableRow (-1) ("-1 s.d.", lows), tableRow (-1) ("+1 s.d.", highs)]) ++ [tableRow (-1) ("Average", gms)]) where -- results_per_prog :: [ (String,[BoxValue a]) ] results_per_prog = map (calc_result rs f stat result_ok convert_to_percentage) (Map.toList r) results_per_run = transpose (map snd results_per_prog) (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run) htmlShowMultiResults :: Result a => [ResultTable] -> [String] -> (Results -> Map String a) -> (a -> Bool) -> HtmlTable htmlShowMultiResults [] _ _ _ = error "htmlShowMultiResults: Can't happen?" htmlShowMultiResults (r:rs) ss f result_ok = multiTabHeader ss aboves (map show_results_for_prog results_per_prog_mod_run) aboves ((if nodevs then [] else [td << bold << "-1 s.d." <-> tableRow (-1) ("", lows), td << bold << "+1 s.d." <-> tableRow (-1) ("", highs)]) ++ [td << bold << "Average" <-> tableRow (-1) ("", gms)]) where base_results = Map.toList r :: [(String,Results)] -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])] results_per_prog_mod_run = map get_results_for_prog base_results -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a]) get_results_for_prog (prog, results) = (prog, map get_results_for_mod (Map.toList (f results))) where fms = map get_run_results rs get_run_results fm = case Map.lookup prog fm of Nothing -> Map.empty Just res -> f res get_results_for_mod id_attr = calc_result fms Just (const Success) result_ok convert_to_percentage id_attr show_results_for_prog (prog,mrs) = td (if null mrs then td << "(no modules compiled)" else toHtml (aboves (map (tableRow 0) mrs))) results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run, (_,xs) <- mods] (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run) tableRow :: Int -> (String, [BoxValue]) -> HtmlTable tableRow row_no (prog, results) = td besides (map (\s -> td [BoxValue a] -> [(Bool,BoxValue a)] findBest stuff@(Result base : rest) = map (\a -> (a==base, a)) where best = snd (minimumBy (\a b -> fst a < fst b) no_pcnt_stuff no_pcnt_stuff = map unPcnt stuff unPcnt (r@(Percentage f) : rest) = (base * f/100, r) : unPcnt rest unPcnt (r@(Result a) : rest) = (a, r) : unPcnt rest unPcnt (_ : rest) = unPcnt rest -} logHeaders :: [String] -> HtmlTable logHeaders ss = besides (map (\s -> (td Html mkTable t = table HtmlTable tabHeader ss = (td logHeaders ss multiTabHeader :: [String] -> HtmlTable multiTabHeader ss = (td (td logHeaders ss -- Calculate a color ranging from bright blue for -100% to bright red for +100%. calcColor :: Int -> String calcColor percentage | percentage >= 0 = printf "#%02x0000" val | otherwise = printf "#0000%02x" val where val = abs percentage * 255 `div` 100 ----------------------------------------------------------------------------- -- LaTeX table generation (just the summary for now) latexOutput :: [ResultTable] -> Maybe String -> [String] -> [PerProgTableSpec] -> Maybe [String] -> Normalise -> String latexOutput results (Just table_name) _ _ _ norm = let table_spec = [ spec | spec@(SpecP _ n _ _ _ _) <- per_prog_result_tab, n == table_name ] in case table_spec of [] -> error ("can't find table named: " ++ table_name) (spec:_) -> latexProgTable results spec norm "\n" latexOutput results Nothing _ summary_spec summary_rows _ = (if (length results == 2) then ascii_summary_table True results summary_spec summary_rows . str "\n\n" else id) "" latexProgTable :: [ResultTable] -> PerProgTableSpec -> Normalise -> ShowS latexProgTable results (SpecP _long_name _ _ get_result get_status result_ok) norm = latex_show_results results get_result get_status result_ok norm latex_show_results :: Result a => [ResultTable] -> (Results -> Maybe a) -> (Results -> Status) -> (a -> Bool) -> Normalise -> ShowS latex_show_results [] _ _ _ _ = error "latex_show_results: Can't happen?" latex_show_results (r:rs) f stat _result_ok norm = makeLatexTable $ [ TableRow (BoxString prog : boxes) | (prog,boxes) <- results_per_prog ] ++ if nodevs then [] else [ TableLine, TableRow (BoxString "Min" : mins), TableRow (BoxString "Max" : maxs), TableRow (BoxString "Geometric Mean" : gms) ] where -- results_per_prog :: [ (String,[BoxValue a]) ] results_per_prog = [ (prog,tail xs) | (prog,xs) <- map calc (Map.toList r) ] calc = calc_result rs f stat (const True) (normalise norm) results_per_run = transpose (map snd results_per_prog) (_lows,gms,_highs) = unzip3 (map calc_gmsd results_per_run) (mins, maxs) = unzip (map calc_minmax results_per_run) normalise :: Result a => Normalise -> a -> a -> BoxValue normalise norm = case norm of NormalisePercent -> convert_to_percentage NormaliseRatio -> normalise_to_base NormaliseNone -> \_base res -> toBox res ----------------------------------------------------------------------------- -- ASCII page generation asciiPage :: [ResultTable] -> [String] -> [PerProgTableSpec] -> Maybe [String] -> Normalise -> String asciiPage results args summary_spec summary_rows norm = ( str reportTitle . str "\n\n" -- only show the summary table if we're comparing two runs . (if (length results == 2) then ascii_summary_table False results summary_spec summary_rows . str "\n\n" else id) . interleave "\n\n" (map (asciiGenProgTable results args norm) per_prog_result_tab) . str "\n" . interleave "\n\n" (map (asciiGenModTable results args) per_module_result_tab) ) "\n" asciiGenProgTable :: [ResultTable] -> [String] -> Normalise -> PerProgTableSpec -> ShowS asciiGenProgTable results args norm (SpecP long_name _ _ get_result get_status result_ok) = str long_name . str "\n" . ascii_show_results results args get_result get_status result_ok norm asciiGenModTable :: [ResultTable] -> [String] -> PerModuleTableSpec -> ShowS asciiGenModTable results args (SpecM long_name _ get_result result_ok) = str long_name . str "\n" . ascii_show_multi_results results args get_result result_ok ascii_header :: Int -> [String] -> ShowS ascii_header w ss = str "\n-------------------------------------------------------------------------------\n" . str (rjustify 15 "Program") . str (space 5) . foldr (.) id (map (str . rjustify w) ss) . str "\n-------------------------------------------------------------------------------\n" ascii_show_results :: Result a => [ResultTable] -> [String] -> (Results -> Maybe a) -> (Results -> Status) -> (a -> Bool) -> Normalise -> ShowS ascii_show_results [] _ _ _ _ _ = error "ascii_show_results: Can't happen?" ascii_show_results (r:rs) ss f stat result_ok norm = ascii_header fIELD_WIDTH ss . interleave "\n" (map show_per_prog_results results_per_prog) . if nodevs then id else str "\n" . show_per_prog_results ("-1 s.d.",lows) . str "\n" . show_per_prog_results ("+1 s.d.",highs) . str "\n" . show_per_prog_results ("Average",gms) where -- results_per_prog :: [ (String,[BoxValue a]) ] results_per_prog = map (calc_result rs f stat result_ok (normalise norm)) (Map.toList r) results_per_run = transpose (map snd results_per_prog) (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run) -- A summary table, useful only when we are comparing two runs. This table -- shows a number of different result categories, one per column. ascii_summary_table :: Bool -- generate a LaTeX table? -> [ResultTable] -> [PerProgTableSpec] -> Maybe [String] -> ShowS ascii_summary_table _ [] _ _ = error "ascii_summary_table: Can't happen?" ascii_summary_table _ [_] _ _ = error "ascii_summary_table: Can't happen?" ascii_summary_table latex (r1:r2:_) specs mb_restrict | latex = makeLatexTable (rows ++ TableLine : av_rows) | otherwise = makeTable (table_layout (length specs) w) (TableLine : TableRow header_row : TableLine : rows ++ TableLine : av_rows) where header_row = BoxString "Program" : map BoxString headings (headings, columns, av_cols) = unzip3 (map calc_col specs) av_heads = [BoxString "Min", BoxString "Max", BoxString "Geometric Mean"] baseline = Map.toList r1 progs = map BoxString (Map.keys r1) rows0 = map TableRow (zipWith (:) progs (transpose columns)) rows1 = restrictRows mb_restrict rows0 rows | latex = mungeForLaTeX rows1 | otherwise = rows1 av_rows = map TableRow (zipWith (:) av_heads (transpose av_cols)) w = 10 calc_col (SpecP _ heading _ getr gets ok) -- throw away the baseline result = (heading, column, [column_min, column_max, column_mean]) where (_, boxes) = unzip (map calc_one_result baseline) calc_one_result = calc_result [r2] getr gets ok convert_to_percentage column = map (\(_:b:_) -> b) boxes (_, column_mean, _) = calc_gmsd column (column_min, column_max) = calc_minmax column restrictRows :: Maybe [String] -> [TableRow] -> [TableRow] restrictRows Nothing rows = rows restrictRows (Just these) rows = filter keep_it rows where keep_it (TableRow (BoxString s: _)) = s `elem` these keep_it TableLine = True keep_it _ = False mungeForLaTeX :: [TableRow] -> [TableRow] mungeForLaTeX = map transrow where transrow (TableRow boxes) = TableRow (map transbox boxes) transrow row = row transbox (BoxString s) = BoxString (foldr transchar "" s) transbox box = box transchar '_' s = '\\':'_':s transchar c s = c:s table_layout :: Int -> Int -> Layout table_layout n w boxes = foldr (.) id $ zipWith ($) fns boxes where fns = (str . rjustify 15 . show ) : (\s -> str (space 5) . str (rjustify w (show s))) : replicate (n-1) (str . rjustify w . show) ascii_show_multi_results :: Result a => [ResultTable] -> [String] -> (Results -> Map String a) -> (a -> Bool) -> ShowS ascii_show_multi_results [] _ _ _ = error "ascii_show_multi_results: Can't happen?" ascii_show_multi_results (r:rs) ss f result_ok = ascii_header fIELD_WIDTH ss . interleave "\n" (map show_results_for_prog results_per_prog_mod_run) . str "\n" . if nodevs then id else str "\n" . show_per_prog_results ("-1 s.d.",lows) . str "\n" . show_per_prog_results ("+1 s.d.",highs) . str "\n" . show_per_prog_results ("Average",gms) where base_results = Map.toList r :: [(String,Results)] -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])] results_per_prog_mod_run = map get_results_for_prog base_results -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a]) get_results_for_prog (prog, results) = (prog, map get_results_for_mod (Map.toList (f results))) where fms = map get_run_results rs get_run_results fm = case Map.lookup prog fm of Nothing -> Map.empty Just res -> f res get_results_for_mod id_attr = calc_result fms Just (const Success) result_ok convert_to_percentage id_attr show_results_for_prog (prog,mrs) = str ("\n"++prog++"\n") . (if null mrs then str "(no modules compiled)\n" else interleave "\n" (map show_per_prog_results mrs)) results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run, (_,xs) <- mods] (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run) show_per_prog_results :: (String, [BoxValue]) -> ShowS show_per_prog_results = show_per_prog_results_width fIELD_WIDTH show_per_prog_results_width :: Int -> (String, [BoxValue]) -> ShowS show_per_prog_results_width w (prog,results) = str (rjustify 15 prog) . str (space 5) . foldr (.) id (map (str . rjustify w . showBox) results) -- ----------------------------------------------------------------------------- -- CSV output csvTable :: [ResultTable] -> String -> Normalise -> String csvTable results table_name norm = let table_spec = [ spec | spec@(SpecP _ n _ _ _ _) <- per_prog_result_tab, n == table_name ] in case table_spec of [] -> error ("can't find table named: " ++ table_name) (spec:_) -> csvProgTable results spec norm "\n" csvProgTable :: [ResultTable] -> PerProgTableSpec -> Normalise -> ShowS csvProgTable results (SpecP _long_name _ _ get_result get_status result_ok) norm = csv_show_results results get_result get_status result_ok norm csv_show_results :: Result a => [ResultTable] -> (Results -> Maybe a) -> (Results -> Status) -> (a -> Bool) -> Normalise -> ShowS csv_show_results [] _ _ _ _ = error "csv_show_results: Can't happen?" csv_show_results (r:rs) f stat _result_ok norm = interleave "\n" results_per_prog where -- results_per_prog :: [ (String,[BoxValue a]) ] results_per_prog = map (result_line . calc) (Map.toList r) calc = calc_result rs f stat (const True) (normalise norm) result_line (prog,boxes) = interleave "," (str prog : map (str.showBox) boxes) -- --------------------------------------------------------------------------- -- Generic stuff for results generation -- calc_result is a nice exercise in higher-order programming... calc_result :: Result a => [Map String b] -- accumulated results -> (b -> Maybe a) -- get a result from the b -> (b -> Status) -- get a status from the b -> (a -> Bool) -- normalise against the baseline? -> (a -> a -> BoxValue) -- how to normalise -> (String,b) -- the baseline result -> (String,[BoxValue]) calc_result rts get_maybe_a get_stat base_ok norm_fn (prog,base_r) = (prog, (just_result m_baseline base_stat : let rts' = map (\rt -> get_stuff (Map.lookup prog rt)) rts get_stuff Nothing = (Nothing, NotDone) get_stuff (Just r) = (get_maybe_a r, get_stat r) in ( case m_baseline of Just baseline | base_ok baseline -> map (\(r,s) -> do_norm r s baseline) rts' _other -> map (\(r,s) -> just_result r s) rts' ))) where m_baseline = get_maybe_a base_r base_stat = get_stat base_r just_result Nothing s = RunFailed s just_result (Just a) _ = toBox a do_norm Nothing s _ = RunFailed s do_norm (Just a) _ baseline = norm_fn baseline a ----------------------------------------------------------------------------- -- Calculating geometric means and standard deviations {- This is done using the log method, to avoid needing really large intermediate results. The formula for a geometric mean is (a1 * .... * an) ^ 1/n which is equivalent to e ^ ( (log a1 + ... + log an) / n ) where log is the natural logarithm function. Similarly, to compute the geometric standard deviation we compute the deviation of each log, take the root-mean-square, and take the exponential again: e ^ sqrt( ( sqr(log a1 - lbar) + ... + sqr(log an - lbar) ) / n ) where lbar is the mean log, (log a1 + ... + log an) / n This is a *factor*: i.e., the 1 s.d. points are (gm/sdf,gm*sdf); do not subtract 100 from gm before performing this calculation. We therefore return a (low, mean, high) triple. -} calc_gmsd :: [BoxValue] -> (BoxValue, BoxValue, BoxValue) calc_gmsd xs | null percentages = (RunFailed NotDone, RunFailed NotDone, RunFailed NotDone) | otherwise = let sqr x = x * x len = fromIntegral (length percentages) logs = map log percentages lbar = sum logs / len st_devs = map (sqr . (lbar-)) logs dbar = sum st_devs / len gm = exp lbar sdf = exp (sqrt dbar) in (Percentage (gm/sdf), Percentage gm, Percentage (gm*sdf)) where percentages = [ if f < 5 then 5 else f | Percentage f <- xs ] -- can't do log(0.0), so exclude zeros -- small values have inordinate effects so cap at -95%. calc_minmax :: [BoxValue] -> (BoxValue, BoxValue) calc_minmax xs | null percentages = (RunFailed NotDone, RunFailed NotDone) | otherwise = (Percentage (minimum percentages), Percentage (maximum percentages)) where percentages = [ if f < 5 then 5 else f | Percentage f <- xs ] ----------------------------------------------------------------------------- -- Show the Results convert_to_percentage :: Result a => a -> a -> BoxValue convert_to_percentage 0 _val = Percentage 100 convert_to_percentage baseline val = Percentage ((realToFrac val / realToFrac baseline) * 100) normalise_to_base :: Result a => a -> a -> BoxValue normalise_to_base 0 _val = BoxFloat 1 normalise_to_base baseline val = BoxFloat (realToFrac baseline / realToFrac val) class Real a => Result a where toBox :: a -> BoxValue -- We assume an Int is a size, and print it in kilobytes. instance Result Int where toBox = BoxInt instance Result Integer where toBox = BoxInteger instance Result Float where toBox = BoxFloat -- ----------------------------------------------------------------------------- -- BoxValues -- The contents of a box in a table data BoxValue = RunFailed Status | Percentage Float | BoxFloat Float | BoxInt Int | BoxInteger Integer | BoxString String showBox :: BoxValue -> String showBox (RunFailed stat) = show_stat stat showBox (Percentage f) = case printf "%.1f%%" (f-100) of xs@('-':_) -> xs xs -> '+':xs showBox (BoxFloat f) = printf "%.2f" f showBox (BoxInt n) = show (n `div` 1024) ++ "k" showBox (BoxInteger n) = show (n `div` 1024) ++ "k" showBox (BoxString s) = s instance Show BoxValue where show = showBox show_stat :: Status -> String show_stat Success = "(no result)" show_stat WrongStdout = "(stdout)" show_stat WrongStderr = "(stderr)" show_stat (Exit x) = "exit(" ++ show x ++")" show_stat OutOfHeap = "(heap)" show_stat OutOfStack = "(stack)" show_stat NotDone = "-----" -- ----------------------------------------------------------------------------- -- Table layout data TableRow = TableRow [BoxValue] | TableLine type Layout = [BoxValue] -> ShowS makeTable :: Layout -> [TableRow] -> ShowS makeTable layout = interleave "\n" . map do_row where do_row (TableRow boxes) = layout boxes do_row TableLine = str (take 80 (repeat '-')) makeLatexTable :: [TableRow] -> ShowS makeLatexTable = foldr (.) id . map do_row where do_row (TableRow boxes) = latexTableLayout boxes . str "\\\\\n" do_row TableLine = str "\\hline\n" latexTableLayout :: Layout latexTableLayout boxes = foldr (.) id . intersperse (str " & ") . map abox $ boxes where abox (RunFailed NotDone) = id abox s = str (foldr transchar "" (show s)) transchar '%' s = s -- leave out the percentage signs transchar c s = c : s -- ----------------------------------------------------------------------------- -- General Utils split :: Char -> String -> [String] split c s = case break (==c) s of (chunk, rest) -> case rest of [] -> [chunk] _:rest' -> chunk : split c rest' str :: String -> ShowS str = showString interleave :: String -> [ShowS] -> ShowS interleave s = foldr1 (\a b -> a . str s . b) fIELD_WIDTH :: Int fIELD_WIDTH = 16 -----------------------------------------------------------------------------