import CmdLine
import Text.Printf
-import Text.Html hiding ((!))
+import Text.Html hiding (cols, rows, (!))
import qualified Text.Html as Html ((!))
import qualified Data.Map as Map
import Data.Map (Map)
-import System.Console.GetOpt
import System.Exit ( exitWith, ExitCode(..) )
-import Numeric ( showFloat, showFFloat, showSigned )
import Control.Monad
import Data.Maybe ( isNothing )
import Data.Char
import System.IO
import Data.List
+(<!) :: Text.Html.ADDATTRS a => a -> [HtmlAttr] -> a
(<!) = (Html.!)
-----------------------------------------------------------------------------
die :: String -> IO a
die s = hPutStr stderr s >> exitWith (ExitFailure 1)
-usageHeader = "usage: nofib-analyse [OPTION...] <logfile1> <logfile2> ..."
-
+main :: IO ()
main = do
when (not (null cmdline_errors) || OptHelp `elem` flags) $
- die (concat cmdline_errors ++ usageInfo usageHeader argInfo)
+ die (concat cmdline_errors ++ usage)
let { html = OptHTMLOutput `elem` flags;
latex = OptLaTeXOutput `elem` flags;
let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args
-- sanity check
- sequence_ [ checkTimes prog res | table <- results,
- (prog,res) <- Map.toList table ]
+ sequence_ [ checkTimes prog res | result_table <- results,
+ (prog,res) <- Map.toList result_table ]
case () of
_ | html ->
(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, muttime_spec, gctime_spec,
+ gcwork_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_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
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,
-- 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, muttime_spec, gctime_spec,
gcwork_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 ]
+cachegrind_summary_specs :: [PerProgTableSpec]
cachegrind_summary_specs =
[ size_spec, alloc_spec, instrs_spec, mreads_spec, mwrite_spec ]
| 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
-----------------------------------------------------------------------------
-- HTML page generation
---htmlPage :: Results -> [String] -> Html
+htmlPage :: [ResultTable] -> [String] -> Html
htmlPage results args
= header << thetitle << reportTitle
+++ hr
+++ 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)
+ ++ map (module_menu_item) per_module_result_tab)
-prog_menu_item (SpecP name _ anc _ _ _) = anchor <! [href ('#':anc)] << name
-module_menu_item (SpecM name anc _ _) = anchor <! [href ('#':anc)] << name
+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)
+ 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 title _ anc get_result get_status result_ok)
= sectHeading title anc
+++ font <! [size "1"]
<< mkTable (htmlShowResults results args get_result get_status result_ok)
+++ hr
+htmlGenModTable :: [ResultTable] -> [String] -> PerModuleTableSpec -> Html
htmlGenModTable results args (SpecM title anc get_result result_ok)
= sectHeading title anc
+++ font <![size "1"]
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,r) = (prog, map get_results_for_mod (Map.toList (f r)))
+ get_results_for_prog (prog, results)
+ = (prog, map get_results_for_mod (Map.toList (f results)))
where fms = map get_run_results rs
Nothing -> Map.empty
Just res -> f res
- get_results_for_mod (id,attr) = calc_result fms Just (const Success)
- result_ok (id,attr)
+ get_results_for_mod id_attr
+ = calc_result fms Just (const Success) result_ok id_attr
show_results_for_prog (prog,mrs) =
td <! [valign "top"] << bold << prog
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 p | p >= 0 = "#" ++ (showHex red 2 "0000")
- | otherwise = "#0000" ++ (showHex blue 2 "")
- where red = p * 255 `div` 100
- blue = (-p) * 255 `div` 100
+calcColor percentage | percentage >= 0 = "#" ++ (showHex val 2 "0000")
+ | otherwise = "#0000" ++ (showHex val 2 "")
+ where val = abs percentage * 255 `div` 100
showHex 0 f s = if f > 0 then take f (repeat '0') ++ s else s
showHex i f s = showHex (i `div` 16) (f-1) (hexDig (i `mod` 16) : s)
width = 10
calc_col (SpecP _ heading _ getr gets ok)
- = (heading, column, [min,max,mean]) -- throw away the baseline result
+ -- 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
column = map (\(_:b:_) -> b) boxes
- (_,mean,_) = calc_gmsd column
- (min,max) = calc_minmax column
+ (_, column_mean, _) = calc_gmsd column
+ (column_min, column_max) = calc_minmax column
restrictRows :: Maybe [String] -> [TableRow] -> [TableRow]
restrictRows Nothing rows = rows
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,r) = (prog, map get_results_for_mod (Map.toList (f r)))
+ get_results_for_prog (prog, results)
+ = (prog, map get_results_for_mod (Map.toList (f results)))
where fms = map get_run_results rs
Nothing -> Map.empty
Just res -> f res
- get_results_for_mod (id,attr) = calc_result fms Just (const Success)
- result_ok (id,attr)
+ get_results_for_mod id_attr
+ = calc_result fms Just (const Success) result_ok id_attr
show_results_for_prog (prog,mrs) =
str ("\n"++prog++"\n")
base_stat = get_stat base_r
just_result Nothing s = RunFailed s
- just_result (Just a) s = toBox a
+ just_result (Just a) _ = toBox a
- percentage Nothing s base = RunFailed s
- percentage (Just a) s base = Percentage
+ percentage Nothing s _ = RunFailed s
+ percentage (Just a) _ base = Percentage
(convert_to_percentage base a)
-----------------------------------------------------------------------------
-- Calculating geometric means and standard deviations
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
- devs = map (sqr . (lbar-)) logs
- dbar = sum devs / len
- gm = exp lbar
- sdf = exp (sqrt dbar)
+ | 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,
-- We assume an Int is a size, and print it in kilobytes.
instance Result Int where
- convert_to_percentage 0 size = 100
- convert_to_percentage base size = (fromIntegral size / fromIntegral base) * 100
+ convert_to_percentage 0 _ = 100
+ convert_to_percentage base size
+ = (fromIntegral size / fromIntegral base) * 100
- toBox = BoxInt
+ toBox = BoxInt
instance Result Integer where
- convert_to_percentage 0 size = 100
- convert_to_percentage base size = (fromInteger size / fromInteger base) * 100
- toBox = BoxInteger
-
+ convert_to_percentage 0 _ = 100
+ convert_to_percentage base size
+ = (fromInteger size / fromInteger base) * 100
+ toBox = BoxInteger
instance Result Float where
- convert_to_percentage 0.0 size = 100.0
- convert_to_percentage base size = size / base * 100
+ convert_to_percentage 0.0 _ = 100.0
+ convert_to_percentage base size = size / base * 100
- toBox = BoxFloat
+ toBox = BoxFloat
-- -----------------------------------------------------------------------------
-- BoxValues
showBox :: BoxValue -> String
showBox (RunFailed stat) = show_stat stat
-showBox (Percentage f) = show_pcntage f
+showBox (Percentage f) = printf "%+.1f%%" (f-100)
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_pcntage n = show_float_signed (n-100) ++ "%"
-
-show_float_signed n
- | n >= 0 = printf "+%.1f" n
- | otherwise = printf "%.1f" n
+instance Show BoxValue where
+ show = showBox
+show_stat :: Status -> String
show_stat Success = "(no result)"
show_stat WrongStdout = "(stdout)"
show_stat WrongStderr = "(stderr)"
type Layout = [String -> ShowS]
makeTable :: Layout -> [TableRow] -> ShowS
-makeTable p = interleave "\n" . map do_row
- where do_row (TableRow boxes) = applyLayout p boxes
+makeTable layout = interleave "\n" . map do_row
+ where do_row (TableRow boxes) = applyLayout layout boxes
do_row TableLine = str (take 80 (repeat '-'))
makeLatexTable :: [TableRow] -> ShowS
_:rest -> chunk : split c rest
where (chunk, rest) = break (==c) s
+str :: String -> ShowS
str = showString
+interleave :: String -> [ShowS] -> ShowS
interleave s = foldr1 (\a b -> a . str s . b)
-fIELD_WIDTH = 16 :: Int
+fIELD_WIDTH :: Int
+fIELD_WIDTH = 16
-----------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff