+++ /dev/null
------------------------------------------------------------------------------
--- $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 Data.Char
-import System.IO
-import Data.List
-
-(<!) :: Text.Html.ADDATTRS a => a -> [HtmlAttr] -> a
-(<!) = (Html.!)
-
------------------------------------------------------------------------------
--- Top level stuff
-
-die :: String -> 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
- :: 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
-
-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
- ]
-
-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]
-
--- 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 ]
-
-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 <! [href ('#':anc)] << long_name
-module_menu_item :: PerModuleTableSpec -> Html
-module_menu_item (SpecM long_name anc _ _)
- = anchor <! [href ('#':anc)] << long_name
-
-gen_tables :: [ResultTable] -> [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 <! [size "1"]
- << mkTable (htmlShowResults results args get_result get_status result_ok)
- +++ hr
-
-htmlGenModTable :: [ResultTable] -> [String] -> PerModuleTableSpec -> Html
-htmlGenModTable results args (SpecM long_name anc get_result result_ok)
- = sectHeading long_name anc
- +++ font <![size "1"]
- << mkTable (htmlShowMultiResults results args get_result result_ok)
- +++ hr
-
-sectHeading :: String -> String -> Html
-sectHeading s nm = h2 << anchor <! [name nm] << s
-
-htmlShowResults
- :: Result a
- => [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 <! [valign "top"] << bold << prog
- <-> (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 <! [bgcolor left_column_color] << prog
- <-> besides (map (\s -> td <! [align "right", clr] << showBox s)
- results)
- where clr | row_no < 0 = bgcolor average_row_color
- | even row_no = bgcolor even_row_color
- | otherwise = bgcolor odd_row_color
-
-left_column_color, odd_row_color, even_row_color, average_row_color :: String
-left_column_color = "#d0d0ff" -- light blue
-odd_row_color = "#d0d0ff" -- light blue
-even_row_color = "#f0f0ff" -- v. light blue
-average_row_color = "#ffd0d0" -- light red
-
-{-
-findBest :: Result a => [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 <! [align "right", width "100"] << bold << s)) ss)
-
-mkTable :: HtmlTable -> Html
-mkTable t = table <! [cellspacing 0, cellpadding 0, border 0] << t
-
-tabHeader :: [String] -> HtmlTable
-tabHeader ss
- = (td <! [align "left", width "100"] << bold << "Program")
- <-> logHeaders ss
-
-multiTabHeader :: [String] -> HtmlTable
-multiTabHeader ss
- = (td <! [align "left", width "100"] << bold << "Program")
- <-> (td <! [align "left", width "100"] << bold << "Module")
- <-> 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
-
------------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff