It's now in the nofib repo.
+++ /dev/null
------------------------------------------------------------------------------
--- CmdLine.hs
-
--- (c) Simon Marlow 2005
------------------------------------------------------------------------------
-
-module CmdLine
- (
- flags, other_args, cmdline_errors,
- devs, nodevs, tooquick_threshold, reportTitle,
- CLIFlags(..), usage,
- )
- where
-
-import System.Console.GetOpt
-import System.Environment ( getArgs )
-import System.IO.Unsafe ( unsafePerformIO )
-
------------------------------------------------------------------------------
--- Command line arguments
-
-args :: [String]
-args = unsafePerformIO getArgs
-
-flags :: [CLIFlags]
-other_args :: [String]
-cmdline_errors :: [String]
-(flags, other_args, cmdline_errors) = getOpt Permute argInfo args
-
-default_tooquick_threshold, tooquick_threshold :: Float
-default_tooquick_threshold = 0.2 {- secs -}
-tooquick_threshold
- = case [ i | OptIgnoreSmallTimes i <- flags ] of
- [] -> default_tooquick_threshold
- (i:_) -> i
-
-devs, nodevs :: Bool
-devs = OptDeviations `elem` flags
-nodevs = OptNoDeviations `elem` flags
-
-default_title, reportTitle :: String
-default_title = "NoFib Results"
-reportTitle = case [ t | OptTitle t <- flags ] of
- [] -> default_title
- (t:_) -> t
-
-data CLIFlags
- = OptASCIIOutput
- | OptLaTeXOutput (Maybe String)
- | OptHTMLOutput
- | OptIgnoreSmallTimes Float
- | OptDeviations
- | OptNoDeviations
- | OptTitle String
- | OptColumns String
- | OptRows String
- | OptCSV String
- | OptNormalise String
- | OptHelp
- deriving Eq
-
-usageHeader :: String
-usageHeader = "usage: nofib-analyse [OPTION...] <logfile1> <logfile2> ..."
-
-usage :: String
-usage = usageInfo usageHeader argInfo
-
-argInfo :: [ OptDescr CLIFlags ]
-argInfo =
- [ Option ['?'] ["help"] (NoArg OptHelp)
- "Display this message"
- , Option ['a'] ["ascii"] (NoArg OptASCIIOutput)
- "Produce ASCII output (default)"
- , Option ['h'] ["html"] (NoArg OptHTMLOutput)
- "Produce HTML output"
- , Option ['i'] ["ignore"] (ReqArg (OptIgnoreSmallTimes . read) "secs")
- "Ignore runtimes smaller than <secs>"
- , Option ['d'] ["deviations"] (NoArg OptDeviations)
- "Display deviations (default)"
- , Option ['l'] ["latex"] (OptArg OptLaTeXOutput "TABLE")
- "Produce LaTeX output"
- , Option [] ["columns"] (ReqArg OptColumns "COLUMNS")
- "Specify columns for summary table (comma separates)"
- , Option [] ["rows"] (ReqArg OptRows "ROWS")
- "Specify rows for summary table (comma separates)"
- , Option [] ["csv"] (ReqArg OptCSV "TABLE")
- "Output a single table in CSV format"
- , Option [] ["normalise"] (ReqArg OptNormalise "percent|ratio|none")
- "normalise to the baseline"
- , Option ['n'] ["nodeviations"] (NoArg OptNoDeviations)
- "Hide deviations"
- , Option ['t'] ["title"] (ReqArg OptTitle "title")
- "Specify report title"
- ]
-
+++ /dev/null
------------------------------------------------------------------------------
--- $Id: GenUtils.lhs,v 1.1 1999/11/12 11:54:17 simonmar Exp $
-
--- Some General Utilities, including sorts, etc.
--- This is realy just an extended prelude.
--- All the code below is understood to be in the public domain.
------------------------------------------------------------------------------
-
-> module GenUtils (
-
-> partition', tack,
-> assocMaybeErr,
-> arrElem,
-> memoise,
-> returnMaybe,handleMaybe, findJust,
-> MaybeErr(..),
-> maybeMap,
-> joinMaybe,
-> mkClosure,
-> foldb,
-> sortWith,
-> sort,
-> cjustify,
-> ljustify,
-> rjustify,
-> space,
-> copy,
-> combinePairs,
-> --trace, -- re-export it
-> fst3,
-> snd3,
-> thd3
-
-#if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 )
-
-> ,Cmp(..), compare, lookup, isJust
-
-#endif
-
-> ) where
-
-#if __HASKELL1__ >= 3 && ( !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 200 )
-
-> import Ix ( Ix(..) )
-> import Array ( listArray, array, (!) )
-
-#define Text Show
-#define ASSOC(a,b) (a , b)
-#else
-#define ASSOC(a,b) (a := b)
-#endif
-
-%------------------------------------------------------------------------------
-
-Here are two defs that everyone seems to define ...
-HBC has it in one of its builtin modules
-
-#ifdef __GOFER__
-
- primitive primPrint "primPrint" :: Int -> a -> ShowS
-
-#endif
-
-#ifdef __GOFER__
-
- primitive primGenericEq "primGenericEq",
- primGenericNe "primGenericNe",
- primGenericLe "primGenericLe",
- primGenericLt "primGenericLt",
- primGenericGe "primGenericGe",
- primGenericGt "primGenericGt" :: a -> a -> Bool
-
- instance Text (Maybe a) where { showsPrec = primPrint }
- instance Eq (Maybe a) where
- (==) = primGenericEq
- (/=) = primGenericNe
-
- instance (Ord a) => Ord (Maybe a)
- where
- Nothing <= _ = True
- _ <= Nothing = True
- (Just a) <= (Just b) = a <= b
-
-#endif
-
-> maybeMap :: (a -> b) -> Maybe a -> Maybe b
-> maybeMap f (Just a) = Just (f a)
-> maybeMap _ Nothing = Nothing
-
-> joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
-> joinMaybe _ Nothing Nothing = Nothing
-> joinMaybe _ (Just g) Nothing = Just g
-> joinMaybe _ Nothing (Just g) = Just g
-> joinMaybe f (Just g) (Just h) = Just (f g h)
-
-> data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Text)
-
-@mkClosure@ makes a closure, when given a comparison and iteration loop.
-Be careful, because if the functional always makes the object different,
-This will never terminate.
-
-> mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a
-> mkClosure eq f = match . iterate f
-> where
-> match (a:b:_) | a `eq` b = a
-> match (_:c) = match c
-> match [] = error "GenUtils.mkClosure: Can't happen"
-
-> foldb :: (a -> a -> a) -> [a] -> a
-> foldb _ [] = error "can't reduce an empty list using foldb"
-> foldb _ [x] = x
-> foldb f l = foldb f (foldb' l)
-> where
-> foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs
-> foldb' (x:y:xs) = f x y : foldb' xs
-> foldb' xs = xs
-
-Merge two ordered lists into one ordered list.
-
-> mergeWith :: (a -> a -> Bool) -> [a] -> [a] -> [a]
-> mergeWith _ [] ys = ys
-> mergeWith _ xs [] = xs
-> mergeWith le (x:xs) (y:ys)
-> | x `le` y = x : mergeWith le xs (y:ys)
-> | otherwise = y : mergeWith le (x:xs) ys
-
-> insertWith :: (a -> a -> Bool) -> a -> [a] -> [a]
-> insertWith _ x [] = [x]
-> insertWith le x (y:ys)
-> | x `le` y = x:y:ys
-> | otherwise = y:insertWith le x ys
-
-Sorting is something almost every program needs, and this is the
-quickest sorting function I know of.
-
-> sortWith :: (a -> a -> Bool) -> [a] -> [a]
-> sortWith _ [] = []
-> sortWith le lst = foldb (mergeWith le) (splitList lst)
-> where
-> splitList (a1:a2:a3:a4:a5:xs) =
-> insertWith le a1
-> (insertWith le a2
-> (insertWith le a3
-> (insertWith le a4 [a5]))) : splitList xs
-> splitList [] = []
-> splitList (r:rs) = [foldr (insertWith le) [r] rs]
-
-> sort :: (Ord a) => [a] -> [a]
-> sort = sortWith (<=)
-
-> returnMaybe :: a -> Maybe a
-> returnMaybe = Just
-
-> handleMaybe :: Maybe a -> Maybe a -> Maybe a
-> handleMaybe m k = case m of
-> Nothing -> k
-> _ -> m
-
-> findJust :: (a -> Maybe b) -> [a] -> Maybe b
-> findJust f = foldr handleMaybe Nothing . map f
-
-
-Gofer-like stuff:
-
-> fst3 :: (a, b, c) -> a
-> fst3 (a, _, _) = a
-> snd3 :: (a, b, c) -> b
-> snd3 (_, a, _) = a
-> thd3 :: (a, b, c) -> c
-> thd3 (_, _, a) = a
-
-> cjustify, ljustify, rjustify :: Int -> String -> String
-> cjustify n s = space halfm ++ s ++ space (m - halfm)
-> where m = n - length s
-> halfm = m `div` 2
-> ljustify n s = s ++ space (n - length s)
-> rjustify n s = let s' = take n s in space (n - length s') ++ s'
-
-> space :: Int -> String
-> space n | n < 0 = ""
-> | otherwise = copy n ' '
-
-> copy :: Int -> a -> [a] -- make list of n copies of x
-> copy n x = take n xs where xs = x:xs
-
-> partition' :: (Eq b) => (a -> b) -> [a] -> [[a]]
-> partition' _ [] = []
-> partition' _ [x] = [[x]]
-> partition' f (x:x':xs) | f x == f x'
-> = tack x (partition' f (x':xs))
-> | otherwise
-> = [x] : partition' f (x':xs)
-
-> tack :: a -> [[a]] -> [[a]]
-> tack x xss = (x : head xss) : tail xss
-
-> combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]
-> combinePairs xs =
-> combine [ (a,[b]) | (a,b) <- sortWith (\ (a,_) (b,_) -> a <= b) xs]
-> where
-> combine [] = []
-> combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r)
-> combine (a:r) = a : combine r
->
-
-#if __HASKELL1__ < 3 || ( defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 200 )
-
-> lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
-> lookup k env = case [ val | (key,val) <- env, k == key] of
-> [] -> Nothing
-> (val:vs) -> Just val
->
-
-> data Cmp = LT | EQ | GT
-
-> compare a b | a < b = LT
-> | a == b = EQ
-> | otherwise = GT
-
-> isJust :: Maybe a -> Bool
-> isJust (Just _) = True
-> isJust _ = False
-
-#endif
-
-> assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String
-> assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of
-> [] -> Failed "assoc: "
-> (val:_) -> Succeeded val
-
-Now some utilties involving arrays.
-Here is a version of @elem@ that uses partual application
-to optimise lookup.
-
-> arrElem :: (Ix a) => [a] -> a -> Bool
-> arrElem obj = \x -> inRange size x && arr ! x
-> where
-> obj' = sort obj
-> size = (head obj',last obj')
-> arr = listArray size [ i `elem` obj | i <- range size ]
-
-
-You can use this function to simulate memoisation. For example:
-
- > fib = memoise (0,100) fib'
- > where
- > fib' 0 = 0
- > fib' 1 = 0
- > fib' n = fib (n-1) + fib (n-2)
-
-will give a very efficent variation of the fib function.
-
-
-> memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b
-> memoise bds f = (!) arr
-> where arr = array bds [ ASSOC(t, f t) | t <- range bds ]
-
+++ /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
-
------------------------------------------------------------------------------
+++ /dev/null
-TOP=../..
-include $(TOP)/mk/boilerplate.mk
-
-SRC_HC_OPTS += -fglasgow-exts -cpp -Wall
-HS_PROG = nofib-analyse
-
-ifeq "$(ghc_ge_607)" "YES"
-SRC_HC_OPTS += -package containers
-endif
-
-SRC_HC_OPTS += -package regex-compat -package html
-
-include $(TOP)/mk/target.mk
+++ /dev/null
------------------------------------------------------------------------------
---
--- (c) Simon Marlow 1997-2005
---
------------------------------------------------------------------------------
-
-module Slurp (Status(..), Results(..), ResultTable, parse_log) where
-
-import Control.Monad
-import qualified Data.Map as Map
-import Data.Map (Map)
-import Text.Regex
-import Data.Maybe
--- import Debug.Trace
-
------------------------------------------------------------------------------
--- This is the structure into which we collect our results:
-
-type ResultTable = Map String Results
-
-data Status
- = NotDone
- | Success
- | OutOfHeap
- | OutOfStack
- | Exit Int
- | WrongStdout
- | WrongStderr
-
-data Results = Results {
- compile_time :: Map String Float,
- module_size :: Map String Int,
- binary_size :: Maybe Int,
- link_time :: Maybe Float,
- run_time :: [Float],
- elapsed_time :: [Float],
- mut_time :: [Float],
- mut_elapsed_time :: [Float],
- instrs :: Maybe Integer,
- mem_reads :: Maybe Integer,
- mem_writes :: Maybe Integer,
- cache_misses :: Maybe Integer,
- gc_work :: Maybe Integer,
- gc_time :: [Float],
- gc_elapsed_time :: [Float],
- gc0_time :: [Float],
- gc0_elapsed_time :: [Float],
- gc1_time :: [Float],
- gc1_elapsed_time :: [Float],
- balance :: [Float],
- allocs :: Maybe Integer,
- run_status :: Status,
- compile_status :: Status
- }
-
-emptyResults :: Results
-emptyResults = Results {
- compile_time = Map.empty,
- module_size = Map.empty,
- binary_size = Nothing,
- link_time = Nothing,
- run_time = [],
- elapsed_time = [],
- mut_time = [],
- mut_elapsed_time = [],
- instrs = Nothing,
- mem_reads = Nothing,
- mem_writes = Nothing,
- cache_misses = Nothing,
- gc_time = [],
- gc_elapsed_time = [],
- gc0_time = [],
- gc0_elapsed_time = [],
- gc1_time = [],
- gc1_elapsed_time = [],
- balance = [],
- gc_work = Nothing,
- allocs = Nothing,
- compile_status = NotDone,
- run_status = NotDone
- }
-
------------------------------------------------------------------------------
--- Parse the log file
-
-{-
-Various banner lines:
-
-==nofib== awards: size of QSort.o follows...
-==nofib== banner: size of banner follows...
-==nofib== awards: time to link awards follows...
-==nofib== awards: time to run awards follows...
-==nofib== boyer2: time to compile Checker follows...
--}
-
--- NB. the hyphen must come last (or first) inside [...] to stand for itself.
-banner_re :: Regex
-banner_re = mkRegex "^==nofib==[ \t]+([A-Za-z0-9_-]+):[ \t]+(size of|time to link|time to run|time to compile|time to compile & run)[ \t]+([A-Za-z0-9_-]+)(\\.o)?[ \t]+follows"
-
-{-
-This regexp for the output of "time" works on FreeBSD, other versions
-of "time" will need different regexps.
--}
-
-time_re :: String -> Maybe (Float, Float, Float)
-time_re s = case matchRegex re s of
- Just [real, user, system] ->
- Just (read real, read user, read system)
- Just _ -> error "time_re: Can't happen"
- Nothing -> Nothing
- where re = mkRegex "^[ \t]*([0-9.]+)[ \t]+real[ \t]+([0-9.]+)[ \t]+user[ \t]+([0-9.]+)[ \t]+sys[ \t]*$"
-
-time_gnu17_re :: String -> Maybe (Float, Float, String)
-time_gnu17_re s = case matchRegex re s of
- Just [user, system, elapsed] ->
- Just (read user, read system, elapsed)
- Just _ -> error "time_gnu17_re: Can't happen"
- Nothing -> Nothing
- where re = mkRegex "^[ \t]*([0-9.]+)user[ \t]+([0-9.]+)system[ \t]+([0-9.:]+)elapsed"
- -- /usr/bin/time --version reports: GNU time 1.7
- -- notice the order is different, and the elapsed time
- -- is [hh:]mm:ss.s
-
-size_re :: String -> Maybe (Int, Int, Int)
-size_re s = case matchRegex re s of
- Just [text, datas, bss] ->
- Just (read text, read datas, read bss)
- Just _ -> error "size_re: Can't happen"
- Nothing -> Nothing
- where re = mkRegex "^[ \t]*([0-9]+)[ \t]+([0-9]+)[ \t]+([0-9]+)"
-
-{-
-<<ghc: 5820820 bytes, 0 GCs, 0/0 avg/max bytes residency (0 samples), 41087234 bytes GC work, 0.00 INIT (0.05 elapsed), 0.08 MUT (0.18 elapsed), 0.00 GC (0.00 elapsed) :ghc>>
-
- = (bytes, gcs, avg_resid, max_resid, samples, gc_work,
- init, init_elapsed, mut, mut_elapsed, gc, gc_elapsed)
-
-ghc1_re = pre GHC 4.02
-ghc2_re = GHC 4.02 (includes "xxM in use")
-ghc3_re = GHC 4.03 (includes "xxxx bytes GC work")
-ghc5_re = GHC 6.9 (includes GC(0) and GC(1) times)
--}
-
-ghc1_re :: String -> Maybe (Integer, Integer, Integer, Integer, Integer, Integer, Float, Float, Float, Float, Float, Float)
-ghc1_re s = case matchRegex re s of
- Just [allocations, gcs, avg_residency, max_residency, samples, gc_work', initialisation, initialisation_elapsed, mut, mut_elapsed, gc, gc_elapsed] ->
- Just (read allocations, read gcs, read avg_residency, read max_residency, read samples, read gc_work', read initialisation, read initialisation_elapsed, read mut, read mut_elapsed, read gc, read gc_elapsed)
- Just _ -> error "ghc1_re: Can't happen"
- Nothing -> Nothing
- where re = mkRegex "^<<ghc:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+) bytes GC work, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\) :ghc>>"
-
-ghc2_re :: String -> Maybe (Integer, Integer, Integer, Integer, Integer, Integer, Float, Float, Float, Float, Float, Float)
-ghc2_re s = case matchRegex re s of
- Just [allocations, gcs, avg_residency, max_residency, samples, in_use, initialisation, initialisation_elapsed, mut, mut_elapsed, gc, gc_elapsed] ->
- Just (read allocations, read gcs, read avg_residency, read max_residency, read samples, read in_use, read initialisation, read initialisation_elapsed, read mut, read mut_elapsed, read gc, read gc_elapsed)
- Just _ -> error "ghc2_re: Can't happen"
- Nothing -> Nothing
- where re = mkRegex "^<<ghc:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+)M in use, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\) :ghc>>"
-
-ghc3_re :: String -> Maybe (Integer, Integer, Integer, Integer, Integer, Integer, Integer, Float, Float, Float, Float, Float, Float)
-ghc3_re s = case matchRegex re s of
- Just [allocations, gcs, avg_residency, max_residency, samples, gc_work', in_use, initialisation, initialisation_elapsed, mut, mut_elapsed, gc, gc_elapsed] ->
- Just (read allocations, read gcs, read avg_residency, read max_residency, read samples, read gc_work', read in_use, read initialisation, read initialisation_elapsed, read mut, read mut_elapsed, read gc, read gc_elapsed)
- Just _ -> error "ghc3_re: Can't happen"
- Nothing -> Nothing
- where re = mkRegex "^<<ghc:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+) bytes GC work, ([0-9]+)M in use, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\) :ghc>>"
-
-ghc4_re :: String -> Maybe (Integer, Integer, Integer, Integer, Integer, Integer, Integer, Float, Float, Float, Float, Float, Float, Integer, Integer, Integer, Integer)
-ghc4_re s = case matchRegex re s of
- Just [allocations, gcs, avg_residency, max_residency, samples, gc_work', in_use, initialisation, initialisation_elapsed, mut, mut_elapsed, gc, gc_elapsed, instructions, memory_reads, memory_writes, l2_cache_misses] ->
- Just (read allocations, read gcs, read avg_residency, read max_residency, read samples, read gc_work', read in_use, read initialisation, read initialisation_elapsed, read mut, read mut_elapsed, read gc, read gc_elapsed, read instructions, read memory_reads, read memory_writes, read l2_cache_misses)
- Just _ -> error "ghc4_re: Can't happen"
- Nothing -> Nothing
- where re = mkRegex "^<<ghc-instrs:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+) bytes GC work, ([0-9]+)M in use, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\), ([0-9]+) instructions, ([0-9]+) memory reads, ([0-9]+) memory writes, ([0-9]+) L2 cache misses :ghc-instrs>>"
-
-ghc5_re :: String -> Maybe (Integer, Integer, Integer, Integer, Integer, Integer, Integer, Float, Float, Float, Float, Float, Float,Float,Float,Float,Float,Float)
-ghc5_re s = case matchRegex re s of
- Just [allocations, gcs, avg_residency, max_residency, samples, gc_work', in_use, initialisation, initialisation_elapsed, mut, mut_elapsed, gc, gc_elapsed, gc0, gc0_elapsed, gc1, gc1_elapsed, bal] ->
- Just (read allocations, read gcs, read avg_residency, read max_residency, read samples, read gc_work', read in_use, read initialisation, read initialisation_elapsed, read mut, read mut_elapsed, read gc, read gc_elapsed, read gc0, read gc0_elapsed, read gc1, read gc1_elapsed, read bal)
- Just _ -> error "ghc3_re: Can't happen"
- Nothing -> Nothing
- where re = mkRegex "^<<ghc:[ \t]+([0-9]+)[ \t]+bytes,[ \t]*([0-9]+)[ \t]+GCs,[ \t]*([0-9]+)/([0-9]+)[ \t]+avg/max bytes residency \\(([0-9]+) samples\\), ([0-9]+) bytes GC work, ([0-9]+)M in use, ([0-9.]+) INIT \\(([0-9.]+) elapsed\\), ([0-9.]+) MUT \\(([0-9.]+) elapsed\\), ([0-9.]+) GC \\(([0-9.]+) elapsed\\), ([0-9.]+) GC\\(0\\) \\(([0-9.]+) elapsed\\), ([0-9.]+) GC\\(1\\) \\(([0-9.]+) elapsed\\), ([0-9.]+) balance :ghc>>"
-
-wrong_exit_status, wrong_output, out_of_heap, out_of_stack :: Regex
-wrong_exit_status = mkRegex "^\\**[ \t]*expected exit status ([0-9]+) not seen ; got ([0-9]+)"
-wrong_output = mkRegex "^expected (stdout|stderr) not matched by reality$"
-out_of_heap = mkRegex "^\\+ Heap exhausted;$"
-out_of_stack = mkRegex "^\\+ Stack space overflow:"
-
-parse_log :: String -> ResultTable
-parse_log
- = combine_results -- collate information
- . concat
- . map process_chunk -- get information from each chunk
- . tail -- first chunk is junk
- . chunk_log [] [] -- break at banner lines
- . lines
-
-combine_results :: [(String,Results)] -> Map String Results
-combine_results = foldr f Map.empty
- where
- f (prog,results) fm = Map.insertWith (flip combine2Results) prog results fm
-
-combine2Results :: Results -> Results -> Results
-combine2Results
- Results{ compile_time = ct1, link_time = lt1,
- module_size = ms1,
- run_time = rt1, elapsed_time = et1, mut_time = mt1,
- mut_elapsed_time = me1,
- instrs = is1, mem_reads = mr1, mem_writes = mw1,
- cache_misses = cm1,
- gc_time = gt1, gc_elapsed_time = ge1, gc_work = gw1,
- gc0_time = g0t1, gc0_elapsed_time = g0e1,
- gc1_time = g1t1, gc1_elapsed_time = g1e1,
- balance = b1,
- binary_size = bs1, allocs = al1,
- run_status = rs1, compile_status = cs1 }
- Results{ compile_time = ct2, link_time = lt2,
- module_size = ms2,
- run_time = rt2, elapsed_time = et2, mut_time = mt2,
- mut_elapsed_time = me2,
- instrs = is2, mem_reads = mr2, mem_writes = mw2,
- cache_misses = cm2,
- gc_time = gt2, gc_elapsed_time = ge2, gc_work = gw2,
- gc0_time = g0t2, gc0_elapsed_time = g0e2,
- gc1_time = g1t2, gc1_elapsed_time = g1e2,
- balance = b2,
- binary_size = bs2, allocs = al2,
- run_status = rs2, compile_status = cs2 }
- = Results{ compile_time = Map.unionWith (flip const) ct1 ct2,
- module_size = Map.unionWith (flip const) ms1 ms2,
- link_time = lt1 `mplus` lt2,
- run_time = rt1 ++ rt2,
- elapsed_time = et1 ++ et2,
- mut_time = mt1 ++ mt2,
- mut_elapsed_time = me1 ++ me2,
- instrs = is1 `mplus` is2,
- mem_reads = mr1 `mplus` mr2,
- mem_writes = mw1 `mplus` mw2,
- cache_misses = cm1 `mplus` cm2,
- gc_time = gt1 ++ gt2,
- gc_elapsed_time= ge1 ++ ge2,
- gc0_time = g0t1 ++ g0t2,
- gc0_elapsed_time= g0e1 ++ g0e2,
- gc1_time = g1t1 ++ g1t2,
- gc1_elapsed_time= g1e1 ++ g1e2,
- balance = b1 ++ b2,
- gc_work = gw1 `mplus` gw2,
- binary_size = bs1 `mplus` bs2,
- allocs = al1 `mplus` al2,
- run_status = combStatus rs1 rs2,
- compile_status = combStatus cs1 cs2 }
-
-combStatus :: Status -> Status -> Status
-combStatus NotDone y = y
-combStatus x NotDone = x
-combStatus x _ = x
-
-chunk_log :: [String] -> [String] -> [String] -> [([String],[String])]
-chunk_log header chunk [] = [(header,chunk)]
-chunk_log header chunk (l:ls) =
- case matchRegex banner_re l of
- Nothing -> chunk_log header (l:chunk) ls
- Just stuff -> (header,chunk) : chunk_log stuff [] ls
-
-process_chunk :: ([String],[String]) -> [(String,Results)]
-process_chunk (progName : what : modName : _, chk) =
- case what of
- "time to compile" -> parse_compile_time progName modName chk
- "time to run" -> parse_run_time progName (reverse chk) emptyResults NotDone
- "time to compile & run" -> parse_compile_time progName modName chk
- ++ parse_run_time progName (reverse chk) emptyResults NotDone
- "time to link" -> parse_link_time progName chk
- "size of" -> parse_size progName modName chk
- _ -> error ("process_chunk: "++what)
-process_chunk _ = error "process_chunk: Can't happen"
-
-parse_compile_time :: String -> String -> [String] -> [(String, Results)]
-parse_compile_time _ _ [] = []
-parse_compile_time progName modName (l:ls) =
- case time_re l of {
- Just (_real, user, _system) ->
- let ct = Map.singleton modName user
- in
- [(progName, emptyResults{compile_time = ct})];
- Nothing ->
-
- case time_gnu17_re l of {
- Just (user, _system, _elapsed) ->
- let ct = Map.singleton modName user
- in
- [(progName, emptyResults{compile_time = ct})];
- Nothing ->
-
- case ghc1_re l of {
- Just (_, _, _, _, _, _, initialisation, _, mut, _, gc, _) ->
- let
- time = (initialisation + mut + gc) :: Float
- ct = Map.singleton modName time
- in
- [(progName, emptyResults{compile_time = ct})];
- Nothing ->
-
- case ghc2_re l of {
- Just (_, _, _, _, _, _, initialisation, _, mut, _, gc, _) ->
- let ct = Map.singleton modName (initialisation + mut + gc)
- in
- [(progName, emptyResults{compile_time = ct})];
- Nothing ->
-
- case ghc3_re l of {
- Just (_, _, _, _, _, _, _, initialisation, _, mut, _, gc, _) ->
- let ct = Map.singleton modName (initialisation + mut + gc)
- in
- [(progName, emptyResults{compile_time = ct})];
- Nothing ->
-
- case ghc4_re l of {
- Just (_, _, _, _, _, _, _, initialisation, _, mut, _, gc, _, _, _, _, _) ->
- let ct = Map.singleton modName (initialisation + mut + gc)
- in
- [(progName, emptyResults{compile_time = ct})];
- Nothing ->
-
- parse_compile_time progName modName ls
- }}}}}}
-
-parse_link_time :: String -> [String] -> [(String, Results)]
-parse_link_time _ [] = []
-parse_link_time prog (l:ls) =
- case time_re l of {
- Just (_real, user, _system) ->
- [(prog,emptyResults{link_time = Just user})];
- Nothing ->
-
- case time_gnu17_re l of {
- Just (user, _system, _elapsed) ->
- [(prog,emptyResults{link_time = Just user})];
- Nothing ->
-
- parse_link_time prog ls
- }}
-
-
--- There might be multiple runs of the program, so we have to collect up
--- all the results. Variable results like runtimes are aggregated into
--- a list, whereas the non-variable aspects are just kept singly.
-parse_run_time :: String -> [String] -> Results -> Status
- -> [(String, Results)]
-parse_run_time _ [] _ NotDone = []
-parse_run_time prog [] res ex = [(prog, res{run_status=ex})]
-parse_run_time prog (l:ls) res ex =
- case ghc1_re l of {
- Just (allocations, _, _, _, _, _, initialisation, init_elapsed, mut, mut_elapsed, gc, gc_elapsed) ->
- got_run_result allocations initialisation init_elapsed mut mut_elapsed gc gc_elapsed [] [] [] [] []
- Nothing Nothing Nothing Nothing Nothing;
- Nothing ->
-
- case ghc2_re l of {
- Just (allocations, _, _, _, _, _, initialisation, init_elapsed, mut, mut_elapsed, gc, gc_elapsed) ->
- got_run_result allocations initialisation init_elapsed mut mut_elapsed gc gc_elapsed [] [] [] [] []
- Nothing Nothing Nothing Nothing Nothing;
-
- Nothing ->
-
- case ghc3_re l of {
- Just (allocations, _, _, _, _, gc_work', _, initialisation, init_elapsed, mut, mut_elapsed, gc, gc_elapsed) ->
- got_run_result allocations initialisation init_elapsed mut mut_elapsed gc gc_elapsed [] [] [] [] []
- (Just gc_work') Nothing Nothing Nothing Nothing;
-
- Nothing ->
-
- case ghc4_re l of {
- Just (allocations, _, _, _, _, gc_work', _, initialisation, init_elapsed, mut, mut_elapsed, gc, gc_elapsed, is, mem_rs, mem_ws, cache_misses') ->
- got_run_result allocations initialisation init_elapsed mut mut_elapsed gc gc_elapsed [] [] [] [] []
- (Just gc_work') (Just is) (Just mem_rs)
- (Just mem_ws) (Just cache_misses');
-
- Nothing ->
-
- case ghc5_re l of {
- Just (allocations, _, _, _, _, gc_work', _, initialisation, init_elapsed, mut, mut_elapsed, gc, gc_elapsed, gc0, gc0_elapsed, gc1, gc1_elapsed, bal) ->
- got_run_result allocations initialisation init_elapsed mut mut_elapsed gc gc_elapsed
- [gc0] [gc0_elapsed] [gc1] [gc1_elapsed] [bal]
- (Just gc_work') Nothing Nothing Nothing Nothing;
-
- Nothing ->
-
- case matchRegex wrong_output l of {
- Just ["stdout"] ->
- parse_run_time prog ls res (combineRunResult WrongStdout ex);
- Just ["stderr"] ->
- parse_run_time prog ls res (combineRunResult WrongStderr ex);
- Just _ -> error "wrong_output: Can't happen";
- Nothing ->
-
- case matchRegex wrong_exit_status l of {
- Just [_wanted, got] ->
- parse_run_time prog ls res (combineRunResult (Exit (read got)) ex);
- Just _ -> error "wrong_exit_status: Can't happen";
- Nothing ->
-
- case matchRegex out_of_heap l of {
- Just _ ->
- parse_run_time prog ls res (combineRunResult OutOfHeap ex);
- Nothing ->
-
- case matchRegex out_of_stack l of {
- Just _ ->
- parse_run_time prog ls res (combineRunResult OutOfStack ex);
- Nothing ->
- parse_run_time prog ls res ex;
-
- }}}}}}}}}
- where
- got_run_result allocations initialisation init_elapsed mut mut_elapsed gc gc_elapsed gc0 gc0_elapsed gc1 gc1_elapsed bal gc_work' instrs' mem_rs mem_ws cache_misses'
- = -- trace ("got_run_result: " ++ initialisation ++ ", " ++ mut ++ ", " ++ gc) $
- let
- time = initialisation + mut + gc
- etime = init_elapsed + mut_elapsed + gc_elapsed
- res' = combine2Results res
- emptyResults{ run_time = [time],
- elapsed_time = [etime],
- mut_time = [mut],
- mut_elapsed_time = [mut_elapsed],
- gc_time = [gc],
- gc_elapsed_time = [gc_elapsed],
- gc0_time = gc0,
- gc0_elapsed_time = gc0_elapsed,
- gc1_time = gc1,
- gc1_elapsed_time = gc1_elapsed,
- balance = bal,
- gc_work = gc_work',
- allocs = Just allocations,
- instrs = instrs',
- mem_reads = mem_rs,
- mem_writes = mem_ws,
- cache_misses = cache_misses',
- run_status = Success
- }
- in
- parse_run_time prog ls res' Success
-
-combineRunResult :: Status -> Status -> Status
-combineRunResult OutOfHeap _ = OutOfHeap
-combineRunResult _ OutOfHeap = OutOfHeap
-combineRunResult OutOfStack _ = OutOfStack
-combineRunResult _ OutOfStack = OutOfStack
-combineRunResult (Exit e) _ = Exit e
-combineRunResult _ (Exit e) = Exit e
-combineRunResult exit _ = exit
-
-parse_size :: String -> String -> [String] -> [(String, Results)]
-parse_size _ _ [] = []
-parse_size progName modName (l:ls) =
- case size_re l of
- Nothing -> parse_size progName modName ls
- Just (text, datas, _bss)
- | progName == modName ->
- [(progName,emptyResults{binary_size =
- Just (text + datas),
- compile_status = Success})]
- | otherwise ->
- let ms = Map.singleton modName (text + datas)
- in
- [(progName,emptyResults{module_size = ms})]
-
projects / ghc-hetmet.git / commitdiff