From: Ian Lynagh Date: Fri, 15 May 2009 20:02:41 +0000 (+0000) Subject: Remove nofib-analyse X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=ab7369b272b3ec6edc197a88f1d0056b82c3efa4 Remove nofib-analyse It's now in the nofib repo. --- diff --git a/utils/nofib-analyse/CmdLine.hs b/utils/nofib-analyse/CmdLine.hs deleted file mode 100644 index 8b60626..0000000 --- a/utils/nofib-analyse/CmdLine.hs +++ /dev/null @@ -1,95 +0,0 @@ ------------------------------------------------------------------------------ --- 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...] ..." - -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 " - , 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" - ] - diff --git a/utils/nofib-analyse/GenUtils.lhs b/utils/nofib-analyse/GenUtils.lhs deleted file mode 100644 index 6a1fb76..0000000 --- a/utils/nofib-analyse/GenUtils.lhs +++ /dev/null @@ -1,257 +0,0 @@ ------------------------------------------------------------------------------ --- $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 ] - diff --git a/utils/nofib-analyse/Main.hs b/utils/nofib-analyse/Main.hs deleted file mode 100644 index 7bcdd58..0000000 --- a/utils/nofib-analyse/Main.hs +++ /dev/null @@ -1,911 +0,0 @@ ------------------------------------------------------------------------------ --- $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 - -( a -> [HtmlAttr] -> a -( IO a -die s = hPutStr stderr s >> exitWith (ExitFailure 1) - -data Normalise = NormalisePercent | NormaliseRatio | NormaliseNone - -main :: IO () -main = do - - when (not (null cmdline_errors) || OptHelp `elem` flags) $ - die (concat cmdline_errors ++ usage) - - norm <- case [ n | OptNormalise n <- flags ] of - [] -> return NormalisePercent - ["percent"] -> return NormalisePercent - ["ratio"] -> return NormaliseRatio - ["none"] -> return NormaliseNone - _ -> die ("unrecognised value for --normalise\n" ++ usage) - - let { html = OptHTMLOutput `elem` flags; - latex = [ t | OptLaTeXOutput t <- flags ]; - ascii = OptASCIIOutput `elem` flags; - csv = [ t | OptCSV t <- flags ]; - } - - when (ascii && html) $ die "Can't produce both ASCII and HTML" - when (devs && nodevs) $ die "Can't both display and hide deviations" - - results <- parse_logs other_args - - summary_spec <- case [ cols | OptColumns cols <- flags ] of - [] -> return (pickSummary results) - (cols:_) -> namedColumns (split ',' cols) - - let summary_rows = case [ rows | OptRows rows <- flags ] of - [] -> Nothing - rows -> Just (split ',' (last rows)) - - let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args - - -- sanity check - sequence_ [ checkTimes prog res | result_table <- results, - (prog,res) <- Map.toList result_table ] - - case () of - _ | not (null csv) -> - putStr (csvTable results (head csv) norm) - _ | html -> - putStr (renderHtml (htmlPage results column_headings)) - _ | not (null latex) -> - putStr (latexOutput results (head latex) column_headings summary_spec summary_rows norm) - _ | otherwise -> - putStr (asciiPage results column_headings summary_spec summary_rows norm) - - -parse_logs :: [String] -> IO [ResultTable] -parse_logs [] = do - f <- hGetContents stdin - return [parse_log f] -parse_logs log_files = - mapM (\f -> do h <- openFile f ReadMode - c <- hGetContents h - return (parse_log c)) log_files - ------------------------------------------------------------------------------ --- List of tables we're going to generate - -data PerProgTableSpec = - forall a . Result a => - SpecP - String -- Name of the table - String -- Short name (for column heading) - String -- HTML tag for the table - (Results -> Maybe a) -- How to get the result - (Results -> Status) -- How to get the status of this result - (a -> Bool) -- Result within reasonable limits? - -data PerModuleTableSpec = - forall a . Result a => - SpecM - String -- Name of the table - String -- HTML tag for the table - (Results -> Map String a) -- get the module map - (a -> Bool) -- Result within reasonable limits? - --- The various per-program aspects of execution that we can generate results for. -size_spec, alloc_spec, runtime_spec, elapsedtime_spec, muttime_spec, mutetime_spec, - gctime_spec, gcelap_spec, - gcwork_spec, instrs_spec, mreads_spec, mwrite_spec, cmiss_spec, - gc0time_spec, gc0elap_spec, gc1time_spec, gc1elap_spec, balance_spec - :: 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 Html -module_menu_item (SpecM long_name anc _ _) - = anchor [String] -> Html -gen_tables results args = - foldr1 (+++) (map (htmlGenProgTable results args) per_prog_result_tab) - +++ foldr1 (+++) (map (htmlGenModTable results args) per_module_result_tab) - -htmlGenProgTable :: [ResultTable] -> [String] -> PerProgTableSpec -> Html -htmlGenProgTable results args (SpecP long_name _ anc get_result get_status result_ok) - = sectHeading long_name anc - +++ font [String] -> PerModuleTableSpec -> Html -htmlGenModTable results args (SpecM long_name anc get_result result_ok) - = sectHeading long_name anc - +++ font String -> Html -sectHeading s nm = h2 << anchor [ResultTable] - -> [String] - -> (Results -> Maybe a) - -> (Results -> Status) - -> (a -> Bool) - -> HtmlTable - -htmlShowResults [] _ _ _ _ - = error "htmlShowResults: Can't happen?" -htmlShowResults (r:rs) ss f stat result_ok - = tabHeader ss - aboves (zipWith tableRow [1..] results_per_prog) - aboves ((if nodevs then [] - else [tableRow (-1) ("-1 s.d.", lows), - tableRow (-1) ("+1 s.d.", highs)]) - ++ [tableRow (-1) ("Average", gms)]) - where - -- results_per_prog :: [ (String,[BoxValue a]) ] - results_per_prog = map (calc_result rs f stat result_ok convert_to_percentage) (Map.toList r) - - results_per_run = transpose (map snd results_per_prog) - (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run) - -htmlShowMultiResults - :: Result a - => [ResultTable] - -> [String] - -> (Results -> Map String a) - -> (a -> Bool) - -> HtmlTable - -htmlShowMultiResults [] _ _ _ - = error "htmlShowMultiResults: Can't happen?" -htmlShowMultiResults (r:rs) ss f result_ok = - multiTabHeader ss - aboves (map show_results_for_prog results_per_prog_mod_run) - aboves ((if nodevs then [] - else [td << bold << "-1 s.d." - <-> tableRow (-1) ("", lows), - td << bold << "+1 s.d." - <-> tableRow (-1) ("", highs)]) - ++ [td << bold << "Average" - <-> tableRow (-1) ("", gms)]) - where - base_results = Map.toList r :: [(String,Results)] - - -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])] - results_per_prog_mod_run = map get_results_for_prog base_results - - -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a]) - get_results_for_prog (prog, results) - = (prog, map get_results_for_mod (Map.toList (f results))) - - where fms = map get_run_results rs - - get_run_results fm = case Map.lookup prog fm of - Nothing -> Map.empty - Just res -> f res - - get_results_for_mod id_attr - = calc_result fms Just (const Success) result_ok convert_to_percentage id_attr - - show_results_for_prog (prog,mrs) = - td (if null mrs then - td << "(no modules compiled)" - else - toHtml (aboves (map (tableRow 0) mrs))) - - results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run, - (_,xs) <- mods] - (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run) - -tableRow :: Int -> (String, [BoxValue]) -> HtmlTable -tableRow row_no (prog, results) - = td besides (map (\s -> td [BoxValue a] -> [(Bool,BoxValue a)] -findBest stuff@(Result base : rest) - = map (\a -> (a==base, a)) - where - best = snd (minimumBy (\a b -> fst a < fst b) no_pcnt_stuff - - no_pcnt_stuff = map unPcnt stuff - - unPcnt (r@(Percentage f) : rest) = (base * f/100, r) : unPcnt rest - unPcnt (r@(Result a) : rest) = (a, r) : unPcnt rest - unPcnt (_ : rest) = unPcnt rest --} - -logHeaders :: [String] -> HtmlTable -logHeaders ss - = besides (map (\s -> (td Html -mkTable t = table HtmlTable -tabHeader ss - = (td logHeaders ss - -multiTabHeader :: [String] -> HtmlTable -multiTabHeader ss - = (td (td logHeaders ss - --- Calculate a color ranging from bright blue for -100% to bright red for +100%. -calcColor :: Int -> String -calcColor percentage | percentage >= 0 = printf "#%02x0000" val - | otherwise = printf "#0000%02x" val - where val = abs percentage * 255 `div` 100 - ------------------------------------------------------------------------------ --- LaTeX table generation (just the summary for now) - -latexOutput :: [ResultTable] -> Maybe String -> [String] -> [PerProgTableSpec] - -> Maybe [String] -> Normalise -> String - -latexOutput results (Just table_name) _ _ _ norm - = let - table_spec = [ spec | spec@(SpecP _ n _ _ _ _) <- per_prog_result_tab, - n == table_name ] - in - case table_spec of - [] -> error ("can't find table named: " ++ table_name) - (spec:_) -> latexProgTable results spec norm "\n" - -latexOutput results Nothing _ summary_spec summary_rows _ = - (if (length results == 2) - then ascii_summary_table True results summary_spec summary_rows - . str "\n\n" - else id) "" - - -latexProgTable :: [ResultTable] -> PerProgTableSpec -> Normalise -> ShowS -latexProgTable results (SpecP _long_name _ _ get_result get_status result_ok) norm - = latex_show_results results get_result get_status result_ok norm - -latex_show_results - :: Result a - => [ResultTable] - -> (Results -> Maybe a) - -> (Results -> Status) - -> (a -> Bool) - -> Normalise - -> ShowS - -latex_show_results [] _ _ _ _ - = error "latex_show_results: Can't happen?" -latex_show_results (r:rs) f stat _result_ok norm - = makeLatexTable $ - [ TableRow (BoxString prog : boxes) | - (prog,boxes) <- results_per_prog ] ++ - if nodevs then [] else - [ TableLine, - TableRow (BoxString "Min" : mins), - TableRow (BoxString "Max" : maxs), - TableRow (BoxString "Geometric Mean" : gms) ] - where - -- results_per_prog :: [ (String,[BoxValue a]) ] - results_per_prog = [ (prog,tail xs) | (prog,xs) <- map calc (Map.toList r) ] - calc = calc_result rs f stat (const True) (normalise norm) - - results_per_run = transpose (map snd results_per_prog) - (_lows,gms,_highs) = unzip3 (map calc_gmsd results_per_run) - (mins, maxs) = unzip (map calc_minmax results_per_run) - -normalise :: Result a => Normalise -> a -> a -> BoxValue -normalise norm = case norm of - NormalisePercent -> convert_to_percentage - NormaliseRatio -> normalise_to_base - NormaliseNone -> \_base res -> toBox res - ------------------------------------------------------------------------------ --- ASCII page generation - -asciiPage :: [ResultTable] -> [String] -> [PerProgTableSpec] -> Maybe [String] - -> Normalise - -> String -asciiPage results args summary_spec summary_rows norm = - ( str reportTitle - . str "\n\n" - -- only show the summary table if we're comparing two runs - . (if (length results == 2) - then ascii_summary_table False results summary_spec summary_rows . str "\n\n" - else id) - . interleave "\n\n" (map (asciiGenProgTable results args norm) per_prog_result_tab) - . str "\n" - . interleave "\n\n" (map (asciiGenModTable results args) per_module_result_tab) - ) "\n" - -asciiGenProgTable :: [ResultTable] -> [String] -> Normalise -> PerProgTableSpec -> ShowS -asciiGenProgTable results args norm (SpecP long_name _ _ get_result get_status result_ok) - = str long_name - . str "\n" - . ascii_show_results results args get_result get_status result_ok norm - -asciiGenModTable :: [ResultTable] -> [String] -> PerModuleTableSpec -> ShowS -asciiGenModTable results args (SpecM long_name _ get_result result_ok) - = str long_name - . str "\n" - . ascii_show_multi_results results args get_result result_ok - -ascii_header :: Int -> [String] -> ShowS -ascii_header w ss - = str "\n-------------------------------------------------------------------------------\n" - . str (rjustify 15 "Program") - . str (space 5) - . foldr (.) id (map (str . rjustify w) ss) - . str "\n-------------------------------------------------------------------------------\n" - -ascii_show_results - :: Result a - => [ResultTable] - -> [String] - -> (Results -> Maybe a) - -> (Results -> Status) - -> (a -> Bool) - -> Normalise - -> ShowS - -ascii_show_results [] _ _ _ _ _ - = error "ascii_show_results: Can't happen?" -ascii_show_results (r:rs) ss f stat result_ok norm - = ascii_header fIELD_WIDTH ss - . interleave "\n" (map show_per_prog_results results_per_prog) - . if nodevs then id - else str "\n" - . show_per_prog_results ("-1 s.d.",lows) - . str "\n" - . show_per_prog_results ("+1 s.d.",highs) - . str "\n" - . show_per_prog_results ("Average",gms) - where - -- results_per_prog :: [ (String,[BoxValue a]) ] - results_per_prog = map (calc_result rs f stat result_ok (normalise norm)) (Map.toList r) - - results_per_run = transpose (map snd results_per_prog) - (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run) - --- A summary table, useful only when we are comparing two runs. This table --- shows a number of different result categories, one per column. -ascii_summary_table - :: Bool -- generate a LaTeX table? - -> [ResultTable] - -> [PerProgTableSpec] - -> Maybe [String] - -> ShowS -ascii_summary_table _ [] _ _ - = error "ascii_summary_table: Can't happen?" -ascii_summary_table _ [_] _ _ - = error "ascii_summary_table: Can't happen?" -ascii_summary_table latex (r1:r2:_) specs mb_restrict - | latex = makeLatexTable (rows ++ TableLine : av_rows) - | otherwise = - makeTable (table_layout (length specs) w) - (TableLine : TableRow header_row : - TableLine : rows ++ - TableLine : av_rows) - where - header_row = BoxString "Program" : map BoxString headings - - (headings, columns, av_cols) = unzip3 (map calc_col specs) - av_heads = [BoxString "Min", BoxString "Max", BoxString "Geometric Mean"] - baseline = Map.toList r1 - progs = map BoxString (Map.keys r1) - rows0 = map TableRow (zipWith (:) progs (transpose columns)) - - rows1 = restrictRows mb_restrict rows0 - - rows | latex = mungeForLaTeX rows1 - | otherwise = rows1 - - av_rows = map TableRow (zipWith (:) av_heads (transpose av_cols)) - w = 10 - - calc_col (SpecP _ heading _ getr gets ok) - -- throw away the baseline result - = (heading, column, [column_min, column_max, column_mean]) - where (_, boxes) = unzip (map calc_one_result baseline) - calc_one_result = calc_result [r2] getr gets ok convert_to_percentage - column = map (\(_:b:_) -> b) boxes - (_, column_mean, _) = calc_gmsd column - (column_min, column_max) = calc_minmax column - -restrictRows :: Maybe [String] -> [TableRow] -> [TableRow] -restrictRows Nothing rows = rows -restrictRows (Just these) rows = filter keep_it rows - where keep_it (TableRow (BoxString s: _)) = s `elem` these - keep_it TableLine = True - keep_it _ = False - -mungeForLaTeX :: [TableRow] -> [TableRow] -mungeForLaTeX = map transrow - where - transrow (TableRow boxes) = TableRow (map transbox boxes) - transrow row = row - - transbox (BoxString s) = BoxString (foldr transchar "" s) - transbox box = box - - transchar '_' s = '\\':'_':s - transchar c s = c:s - -table_layout :: Int -> Int -> Layout -table_layout n w boxes = foldr (.) id $ zipWith ($) fns boxes - where fns = (str . rjustify 15 . show ) : - (\s -> str (space 5) . str (rjustify w (show s))) : - replicate (n-1) (str . rjustify w . show) - -ascii_show_multi_results - :: Result a - => [ResultTable] - -> [String] - -> (Results -> Map String a) - -> (a -> Bool) - -> ShowS - -ascii_show_multi_results [] _ _ _ - = error "ascii_show_multi_results: Can't happen?" -ascii_show_multi_results (r:rs) ss f result_ok - = ascii_header fIELD_WIDTH ss - . interleave "\n" (map show_results_for_prog results_per_prog_mod_run) - . str "\n" - . if nodevs then id - else str "\n" - . show_per_prog_results ("-1 s.d.",lows) - . str "\n" - . show_per_prog_results ("+1 s.d.",highs) - . str "\n" - . show_per_prog_results ("Average",gms) - where - base_results = Map.toList r :: [(String,Results)] - - -- results_per_prog_mod_run :: [(String,[(String,[BoxValue a])])] - results_per_prog_mod_run = map get_results_for_prog base_results - - -- get_results_for_prog :: (String,Results) -> (String,[BoxValue a]) - get_results_for_prog (prog, results) - = (prog, map get_results_for_mod (Map.toList (f results))) - - where fms = map get_run_results rs - - get_run_results fm = case Map.lookup prog fm of - Nothing -> Map.empty - Just res -> f res - - get_results_for_mod id_attr - = calc_result fms Just (const Success) result_ok convert_to_percentage id_attr - - show_results_for_prog (prog,mrs) = - str ("\n"++prog++"\n") - . (if null mrs then - str "(no modules compiled)\n" - else - interleave "\n" (map show_per_prog_results mrs)) - - results_per_run = transpose [xs | (_,mods) <- results_per_prog_mod_run, - (_,xs) <- mods] - (lows,gms,highs) = unzip3 (map calc_gmsd results_per_run) - - -show_per_prog_results :: (String, [BoxValue]) -> ShowS -show_per_prog_results = show_per_prog_results_width fIELD_WIDTH - -show_per_prog_results_width :: Int -> (String, [BoxValue]) -> ShowS -show_per_prog_results_width w (prog,results) - = str (rjustify 15 prog) - . str (space 5) - . foldr (.) id (map (str . rjustify w . showBox) results) - --- ----------------------------------------------------------------------------- --- CSV output - -csvTable :: [ResultTable] -> String -> Normalise -> String -csvTable results table_name norm - = let - table_spec = [ spec | spec@(SpecP _ n _ _ _ _) <- per_prog_result_tab, - n == table_name ] - in - case table_spec of - [] -> error ("can't find table named: " ++ table_name) - (spec:_) -> csvProgTable results spec norm "\n" - -csvProgTable :: [ResultTable] -> PerProgTableSpec -> Normalise -> ShowS -csvProgTable results (SpecP _long_name _ _ get_result get_status result_ok) norm - = csv_show_results results get_result get_status result_ok norm - -csv_show_results - :: Result a - => [ResultTable] - -> (Results -> Maybe a) - -> (Results -> Status) - -> (a -> Bool) - -> Normalise - -> ShowS - -csv_show_results [] _ _ _ _ - = error "csv_show_results: Can't happen?" -csv_show_results (r:rs) f stat _result_ok norm - = interleave "\n" results_per_prog - where - -- results_per_prog :: [ (String,[BoxValue a]) ] - results_per_prog = map (result_line . calc) (Map.toList r) - calc = calc_result rs f stat (const True) (normalise norm) - - result_line (prog,boxes) = interleave "," (str prog : map (str.showBox) boxes) - --- --------------------------------------------------------------------------- --- Generic stuff for results generation - --- calc_result is a nice exercise in higher-order programming... -calc_result - :: Result a - => [Map String b] -- accumulated results - -> (b -> Maybe a) -- get a result from the b - -> (b -> Status) -- get a status from the b - -> (a -> Bool) -- normalise against the baseline? - -> (a -> a -> BoxValue) -- how to normalise - -> (String,b) -- the baseline result - -> (String,[BoxValue]) - -calc_result rts get_maybe_a get_stat base_ok norm_fn (prog,base_r) = - (prog, (just_result m_baseline base_stat : - - let - rts' = map (\rt -> get_stuff (Map.lookup prog rt)) rts - - get_stuff Nothing = (Nothing, NotDone) - get_stuff (Just r) = (get_maybe_a r, get_stat r) - in - ( - case m_baseline of - Just baseline | base_ok baseline - -> map (\(r,s) -> do_norm r s baseline) rts' - _other - -> map (\(r,s) -> just_result r s) rts' - ))) - where - m_baseline = get_maybe_a base_r - base_stat = get_stat base_r - - just_result Nothing s = RunFailed s - just_result (Just a) _ = toBox a - - do_norm Nothing s _ = RunFailed s - do_norm (Just a) _ baseline = norm_fn baseline a - ------------------------------------------------------------------------------ --- Calculating geometric means and standard deviations - -{- -This is done using the log method, to avoid needing really large -intermediate results. The formula for a geometric mean is - - (a1 * .... * an) ^ 1/n - -which is equivalent to - - e ^ ( (log a1 + ... + log an) / n ) - -where log is the natural logarithm function. - -Similarly, to compute the geometric standard deviation we compute the -deviation of each log, take the root-mean-square, and take the -exponential again: - - e ^ sqrt( ( sqr(log a1 - lbar) + ... + sqr(log an - lbar) ) / n ) - -where lbar is the mean log, - - (log a1 + ... + log an) / n - -This is a *factor*: i.e., the 1 s.d. points are (gm/sdf,gm*sdf); do -not subtract 100 from gm before performing this calculation. - -We therefore return a (low, mean, high) triple. - --} - -calc_gmsd :: [BoxValue] -> (BoxValue, BoxValue, BoxValue) -calc_gmsd xs - | null percentages = (RunFailed NotDone, RunFailed NotDone, RunFailed NotDone) - | otherwise = let sqr x = x * x - len = fromIntegral (length percentages) - logs = map log percentages - lbar = sum logs / len - st_devs = map (sqr . (lbar-)) logs - dbar = sum st_devs / len - gm = exp lbar - sdf = exp (sqrt dbar) - in - (Percentage (gm/sdf), - Percentage gm, - Percentage (gm*sdf)) - where - percentages = [ if f < 5 then 5 else f | Percentage f <- xs ] - -- can't do log(0.0), so exclude zeros - -- small values have inordinate effects so cap at -95%. - -calc_minmax :: [BoxValue] -> (BoxValue, BoxValue) -calc_minmax xs - | null percentages = (RunFailed NotDone, RunFailed NotDone) - | otherwise = (Percentage (minimum percentages), - Percentage (maximum percentages)) - where - percentages = [ if f < 5 then 5 else f | Percentage f <- xs ] - - ------------------------------------------------------------------------------ --- Show the Results - -convert_to_percentage :: Result a => a -> a -> BoxValue -convert_to_percentage 0 _val = Percentage 100 -convert_to_percentage baseline val = Percentage ((realToFrac val / realToFrac baseline) * 100) - -normalise_to_base :: Result a => a -> a -> BoxValue -normalise_to_base 0 _val = BoxFloat 1 -normalise_to_base baseline val = BoxFloat (realToFrac baseline / realToFrac val) - -class Real a => Result a where - toBox :: a -> BoxValue - --- We assume an Int is a size, and print it in kilobytes. - -instance Result Int where - toBox = BoxInt - -instance Result Integer where - toBox = BoxInteger - -instance Result Float where - toBox = BoxFloat - --- ----------------------------------------------------------------------------- --- BoxValues - --- The contents of a box in a table -data BoxValue - = RunFailed Status - | Percentage Float - | BoxFloat Float - | BoxInt Int - | BoxInteger Integer - | BoxString String - -showBox :: BoxValue -> String -showBox (RunFailed stat) = show_stat stat -showBox (Percentage f) = case printf "%.1f%%" (f-100) of - xs@('-':_) -> xs - xs -> '+':xs -showBox (BoxFloat f) = printf "%.2f" f -showBox (BoxInt n) = show (n `div` 1024) ++ "k" -showBox (BoxInteger n) = show (n `div` 1024) ++ "k" -showBox (BoxString s) = s - -instance Show BoxValue where - show = showBox - -show_stat :: Status -> String -show_stat Success = "(no result)" -show_stat WrongStdout = "(stdout)" -show_stat WrongStderr = "(stderr)" -show_stat (Exit x) = "exit(" ++ show x ++")" -show_stat OutOfHeap = "(heap)" -show_stat OutOfStack = "(stack)" -show_stat NotDone = "-----" - --- ----------------------------------------------------------------------------- --- Table layout - -data TableRow - = TableRow [BoxValue] - | TableLine - -type Layout = [BoxValue] -> ShowS - -makeTable :: Layout -> [TableRow] -> ShowS -makeTable layout = interleave "\n" . map do_row - where do_row (TableRow boxes) = layout boxes - do_row TableLine = str (take 80 (repeat '-')) - -makeLatexTable :: [TableRow] -> ShowS -makeLatexTable = foldr (.) id . map do_row - where do_row (TableRow boxes) - = latexTableLayout boxes . str "\\\\\n" - do_row TableLine - = str "\\hline\n" - -latexTableLayout :: Layout -latexTableLayout boxes = - foldr (.) id . intersperse (str " & ") . map abox $ boxes - where - abox (RunFailed NotDone) = id - abox s = str (foldr transchar "" (show s)) - - transchar '%' s = s -- leave out the percentage signs - transchar c s = c : s - --- ----------------------------------------------------------------------------- --- General Utils - -split :: Char -> String -> [String] -split c s = case break (==c) s of - (chunk, rest) -> - case rest of - [] -> [chunk] - _:rest' -> chunk : split c rest' - -str :: String -> ShowS -str = showString - -interleave :: String -> [ShowS] -> ShowS -interleave s = foldr1 (\a b -> a . str s . b) - -fIELD_WIDTH :: Int -fIELD_WIDTH = 16 - ------------------------------------------------------------------------------ diff --git a/utils/nofib-analyse/Makefile b/utils/nofib-analyse/Makefile deleted file mode 100644 index 0c04aa3..0000000 --- a/utils/nofib-analyse/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -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 diff --git a/utils/nofib-analyse/Slurp.hs b/utils/nofib-analyse/Slurp.hs deleted file mode 100644 index fc605c8..0000000 --- a/utils/nofib-analyse/Slurp.hs +++ /dev/null @@ -1,467 +0,0 @@ ------------------------------------------------------------------------------ --- --- (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]+)" - -{- -<> - - = (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 "^<>" - -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 "^<>" - -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 "^<>" - -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 "^<>" - -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 "^<>" - -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})] -