From b7081c5f00ef3947dbb39f942b4c5edaf524b3b5 Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 12 Nov 1999 11:54:17 +0000 Subject: [PATCH] [project @ 1999-11-12 11:54:09 by simonmar] Initial revision --- glafp-utils/nofib-analyse/ClassTable.hs | 94 +++++++ glafp-utils/nofib-analyse/CmdLine.hs | 43 +++ glafp-utils/nofib-analyse/DataHtml.hs | 309 +++++++++++++++++++++ glafp-utils/nofib-analyse/GenUtils.lhs | 297 ++++++++++++++++++++ glafp-utils/nofib-analyse/Main.hs | 462 +++++++++++++++++++++++++++++++ glafp-utils/nofib-analyse/Makefile | 7 + glafp-utils/nofib-analyse/OptTable.hs | 92 ++++++ glafp-utils/nofib-analyse/Printf.lhs | 56 ++++ glafp-utils/nofib-analyse/Slurp.hs | 354 +++++++++++++++++++++++ 9 files changed, 1714 insertions(+) create mode 100644 glafp-utils/nofib-analyse/ClassTable.hs create mode 100644 glafp-utils/nofib-analyse/CmdLine.hs create mode 100644 glafp-utils/nofib-analyse/DataHtml.hs create mode 100644 glafp-utils/nofib-analyse/GenUtils.lhs create mode 100644 glafp-utils/nofib-analyse/Main.hs create mode 100644 glafp-utils/nofib-analyse/Makefile create mode 100644 glafp-utils/nofib-analyse/OptTable.hs create mode 100644 glafp-utils/nofib-analyse/Printf.lhs create mode 100644 glafp-utils/nofib-analyse/Slurp.hs diff --git a/glafp-utils/nofib-analyse/ClassTable.hs b/glafp-utils/nofib-analyse/ClassTable.hs new file mode 100644 index 0000000..78a1699 --- /dev/null +++ b/glafp-utils/nofib-analyse/ClassTable.hs @@ -0,0 +1,94 @@ +----------------------------------------------------------------------------- +-- TableClass : Class for combinators used in building 2D tables. +-- +-- Copyright (c) 1999 Andy Gill +-- +-- This module is distributed as Open Source software under the +-- Artistic License; see the file "Artistic" that is included +-- in the distribution for details. +----------------------------------------------------------------------------- + +module ClassTable ( + Table(..), + showsTable, + showTable, + ) where + +infixr 4 `beside` +infixr 3 `above` + +{---------------------------------------------------------------------------- + These combinators can be used to build formated 2D tables. + The specific target useage is for HTML table generation. + ---------------------------------------------------------------------------- + + Examples of use: + + > table1 :: (Table t) => t String + > table1 = single "Hello" +-----+ + |Hello| + This is a 1x1 cell +-----+ + Note: single has type + + single :: (Table t) => a -> t a + + So the cells can contain anything. + + > table2 :: (Table t) => t String + > table2 = single "World" +-----+ + |World| + +-----+ + + + > table3 :: (Table t) => t String + > table3 = table1 %-% table2 +-----%-----+ + |Hello%World| + % is used to indicate +-----%-----+ + the join edge between + the two Tables. + + > table4 :: (Table t) => t String + > table4 = table3 %/% table2 +-----+-----+ + |Hello|World| + Notice the padding on the %%%%%%%%%%%%% + smaller (bottom) cell to |World | + force the table to be a +-----------+ + rectangle. + + > table5 :: (Table t) => t String + > table5 = table1 %-% table4 +-----%-----+-----+ + |Hello%Hello|World| + Notice the padding on the | %-----+-----+ + leftmost cell, again to | %World | + force the table to be a +-----%-----------+ + rectangle. + + Now the table can be rendered with processTable, for example: + Main> processTable table5 + [[("Hello",(1,2)), + ("Hello",(1,1)), + ("World",(1,1))], + [("World",(2,1))]] :: [[([Char],(Int,Int))]] + Main> + +----------------------------------------------------------------------------} + +class Table t where + -- There are no empty tables + + --Single element table + single :: a -> t a + -- horizontal composition + beside :: t a -> t a -> t a + -- vertical composition + above :: t a -> t a -> t a + -- generation of raw table matrix + getMatrix :: t a -> [[(a,(Int,Int))]] + +showsTable :: (Show a,Table t) => t a -> ShowS +showsTable table = shows (getMatrix table) + +showTable :: (Show a,Table t) => t a -> String +showTable table = showsTable table "" + + diff --git a/glafp-utils/nofib-analyse/CmdLine.hs b/glafp-utils/nofib-analyse/CmdLine.hs new file mode 100644 index 0000000..4dfc9f9 --- /dev/null +++ b/glafp-utils/nofib-analyse/CmdLine.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- CmdLine.hs + +-- (c) Simon Marlow 1999 +----------------------------------------------------------------------------- + +module CmdLine where + +import GetOpt +import System +import IOExts + +----------------------------------------------------------------------------- +-- Command line arguments + +args = unsafePerformIO getArgs +(flags, other_args, cmdline_errors) = getOpt Permute argInfo args + +default_tooquick_threshold = 0.2 {- secs -} :: Float +tooquick_threshold + = case [ i | OptIgnoreSmallTimes i <- flags ] of + [] -> default_tooquick_threshold + (i:_) -> i + +data CLIFlags + = OptASCIIOutput + | OptHTMLOutput + | OptIgnoreSmallTimes Float + | OptHelp + deriving Eq + +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 " + ] + diff --git a/glafp-utils/nofib-analyse/DataHtml.hs b/glafp-utils/nofib-analyse/DataHtml.hs new file mode 100644 index 0000000..75aca4c --- /dev/null +++ b/glafp-utils/nofib-analyse/DataHtml.hs @@ -0,0 +1,309 @@ +------------------------------------------------------------------------------- +-- $Id: DataHtml.hs,v 1.1 1999/11/12 11:54:17 simonmar Exp $ +-- +-- Copyright (c) 1999 Andy Gill +------------------------------------------------------------------------------- + +module DataHtml ( + Html, HtmlName, HtmlAttr, HtmlTable, + (+++), verbatim, {- tag, atag, -} noHtml, primHtml, + concatHtml, htmlStr, htmlLine, + h1,h2,h3,h4,h5,h6, + font, bold, anchor, header, body, theTitle, paragraph, italics, + ul, tt, + bar, meta, li, + {- tr, int, percent -} + color, bgcolor, href, name, title, height, width, align, valign, + border, size, cellpadding, cellspacing, + p, hr, copyright, spaceHtml, + renderHtml, + cellHtml, (+/+), above, (+-+), beside, aboves, besides, + renderTable, simpleTable, + ) where + +import qualified OptTable as OT + +infixr 5 +++ -- appending Html +infixr 3 +/+ -- combining HtmlTable +infixr 4 +-+ -- combining HtmlTable + +data Html + = HtmlAppend Html Html -- Some Html, followed by more text + | HtmlVerbatim Html -- Turn on or off smart formating + | HtmlEmpty -- Nothing! + | HtmlNestingTag HtmlName [HtmlAttr] Html + | HtmlSimpleTag HtmlName [HtmlAttr] + | HtmlString String + deriving (Show) + +{- + - A important property of Html is all strings inside the + - structure are already in Html friendly format. + - For example, use of >,etc. + -} + +type HtmlName = String +type HtmlAttr = (HtmlName,Either Int String) +type HtmlTable = OT.OptTable (Int -> Int -> Html) + +------------------------------------------------------------------------------ +-- Interface +------------------------------------------------------------------------------ + +-- primitive combinators +(+++) :: Html -> Html -> Html +verbatim :: Html -> Html +tag :: String -> [HtmlAttr] -> Html -> Html +atag :: String -> [HtmlAttr] -> Html +noHtml :: Html +primHtml :: String -> Html + +-- useful combinators +concatHtml :: [Html] -> Html +htmlStr, htmlLine :: String -> Html + +-- html constructors +h1,h2,h3,h4,h5,h6 :: [HtmlAttr] -> Html -> Html +font, bold, anchor, + header, body, + theTitle, paragraph, + italics, ul, tt :: [HtmlAttr] -> Html -> Html +bar, meta, li :: [HtmlAttr] -> Html + +-- html attributes +str :: String -> String -> HtmlAttr +int :: String -> Int -> HtmlAttr +percent :: String -> Int -> HtmlAttr + +color, bgcolor, href, + name, title, height, + width, align, valign :: String -> HtmlAttr + +border, size, + cellpadding, + cellspacing :: Int -> HtmlAttr + +-- abbriviations + +p :: Html -> Html +hr :: Html +copyright :: Html +spaceHtml :: Html + +-- rendering +renderHtml :: Html -> String + +-- html tables +cellHtml :: [HtmlAttr] -> Html -> HtmlTable +(+/+),above, + (+-+),beside :: HtmlTable -> HtmlTable -> HtmlTable +aboves, besides :: [HtmlTable] -> HtmlTable +renderTable :: [HtmlAttr] -> HtmlTable -> Html +simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] + -> Html + +------------------------------------------------------------------------------ +-- Basic, primitive combinators + +-- This is intentionally lazy in the second argument. +(HtmlAppend x y) +++ z = x +++ (y +++ z) +(HtmlEmpty) +++ z = z +x +++ z = HtmlAppend x z + +verbatim = HtmlVerbatim +tag = HtmlNestingTag +atag = HtmlSimpleTag +noHtml = HtmlEmpty + +-- This is not processed for special chars. +-- It is used to output them, though! +primHtml = HtmlString + +------------------------------------------------------------------------------ +-- Useful Combinators + +concatHtml = foldr (+++) noHtml +-- Processing Strings into Html friendly things. +-- This converts a string to an Html. +htmlStr = primHtml . htmlizeStr + +-- This converts a string, but keeps spaces as non-line-breakable +htmlLine = primHtml . concat . map htmlizeChar2 + where + htmlizeChar2 ' ' = " " + htmlizeChar2 c = htmlizeChar c + +-- Local Utilites +htmlizeStr :: String -> String +htmlizeStr = concat . map htmlizeChar + +htmlizeChar :: Char -> String +htmlizeChar '<' = ">" +htmlizeChar '>' = "<" +htmlizeChar '&' = "&amb;" +htmlizeChar '"' = """ +htmlizeChar c = [c] + +------------------------------------------------------------------------------ +-- Html Constructors +h n = tag ("h" ++ show n) + +-- Isn't Haskell great! +[h1,h2,h3,h4,h5,h6] = map h [1..6] + +-- tags +font = tag "font" +bold = tag "b" +anchor = tag "a" +header = tag "header" +body = tag "body" +theTitle = tag "title" +paragraph = tag "p" +italics = tag "i" +ul = tag "ul" +tt = tag "tt" + +bar = atag "hr" +meta = atag "meta" +li = atag "li" + +------------------------------------------------------------------------------ +-- Html Attributes + +-- note: the string is presumed to be formated for output +--str :: String -> String -> HtmlAttr +str n s = (n,Right s) + +--int :: String -> Int -> HtmlAttr +int n v = (n,Left v) + +--percent :: String -> Int -> HtmlAttr +percent n v = str n (show v ++ "%") + +-- attributes +color = str "color" +bgcolor = str "bgcolor" +href = str "href" +name = str "name" +title = str "tile" +height = str "height" +width = str "width" +align = str "align" +valign = str "valign" + +border = int "border" +size = int "size" +cellpadding = int "cellpadding" +cellspacing = int "cellspacing" + +------------------------------------------------------------------------------ +-- abbriviations +p = paragraph [] +hr = atag "hr" [] +copyright = primHtml "©" +spaceHtml = primHtml " " + +------------------------------------------------------------------------------ +-- Rendering + +renderHtml html = renderHtml' html (Just 0) ++ footerMessage + +footerMessage + = "\n\n" + +renderHtml' (HtmlAppend html1 html2) d + = renderHtml' html1 d ++ renderHtml' html2 d +renderHtml' (HtmlVerbatim html1) d + = renderHtml' html1 Nothing +renderHtml' (HtmlEmpty) d = "" +renderHtml' (HtmlSimpleTag name attr) d + = renderTag True name attr d +renderHtml' (HtmlNestingTag name attr html) d + = renderTag True name attr d ++ renderHtml' html (incDepth d) ++ + renderTag False name [] d +renderHtml' (HtmlString str) _ = str + +incDepth :: Maybe Int -> Maybe Int +incDepth = fmap (+4) + +-- This prints the tags in +renderTag :: Bool -> HtmlName -> [HtmlAttr] -> Maybe Int -> String +renderTag x name attrs n = start ++ base_spaces ++ open ++ name ++ rest attrs ++ ">" + where + open = if x then "<" else " ("",""," ") + Just n -> ("\n",replicate n ' ',"\n") + + rest [] = "" + rest [(tag,val)] = " " ++ tag ++ "=" ++ myShow val + rest (hd:tl) = " " ++ showPair hd ++ sep ++ + foldr1 (\ x y -> x ++ sep ++ y) + [ base_spaces ++ replicate (1 + length name + 1) ' ' + ++ showPair p | p <- tl ] + + showPair :: HtmlAttr -> String + showPair (tag,val) = tag ++ replicate (tagsz - length tag) ' ' ++ + " = " ++ myShow val + myShow (Left n) = show n + myShow (Right s) = "\"" ++ s ++ "\"" + + tagsz = maximum (map (length.fst) attrs) + +------------------------------------------------------------------------------ +-- Html table related things + +cellHtml attr html = OT.single cellFn + where + cellFn x y = tag "td" (addX x (addY y attr)) html + addX 1 rest = rest + addX n rest = int "colspan" n : rest + addY 1 rest = rest + addY n rest = int "rowspan" n : rest + +above = OT.above +(+/+) = above +beside = OT.beside +(+-+) = beside + +{- + - Note: Both aboves and besides presume a non-empty list. + -} + +aboves = foldl1 (+/+) +besides = foldl1 (+-+) + +-- renderTable takes the HtmlTable, and renders it back into +-- and Html object. The attributes are added to the outside +-- table tag. + +renderTable attr theTable + = table [row [theCell x y | (theCell,(x,y)) <- theRow ] + | theRow <- OT.getMatrix theTable] + where + row :: [Html] -> Html + row = tag "tr" [] . concatHtml + + table :: [Html] -> Html + table = tag "table" attr . concatHtml + +-- If you cant be bothered with the above, then you +-- can build simple tables with this. +-- Just provide the attributes for the whole table, +-- attributes for the cells (same for every cell), +-- and a list of list of cell contents, +-- and this function will build the table for you. +-- It does presume that all the lists are non-empty, +-- and there is at least one list. +-- +-- Different length lists means that the last cell +-- gets padded. If you want more power, then +-- use the system above. + +simpleTable attr cellAttr + = renderTable attr + . aboves + . map (besides . map (cellHtml cellAttr)) + + +------------------------------------------------------------------------------ diff --git a/glafp-utils/nofib-analyse/GenUtils.lhs b/glafp-utils/nofib-analyse/GenUtils.lhs new file mode 100644 index 0000000..540199f --- /dev/null +++ b/glafp-utils/nofib-analyse/GenUtils.lhs @@ -0,0 +1,297 @@ +----------------------------------------------------------------------------- +-- $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 f 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:c) | a `eq` b = a +> match (_:c) = match c + +> foldb :: (a -> a -> a) -> [a] -> a +> foldb f [] = error "can't reduce an empty list using foldb" +> foldb f [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 le [] = [] +> 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,_,_) = a +> snd3 (_,a,_) = a +> 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' f [] = [] +> partition' f [x] = [[x]] +> partition' f (x:x':xs) | f x == f x' +> = tack x (partition' f (x':xs)) +> | otherwise +> = [x] : partition' f (x':xs) + +> 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:vs) -> 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 ] + +> mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list +> -- and accumulator, returning new +> -- accumulator and elt of result list +> -> acc -- Initial accumulator +> -> [x] -- Input list +> -> (acc, [y]) -- Final accumulator and result list +> +> mapAccumR f b [] = (b, []) +> mapAccumR f b (x:xs) = (b'', x':xs') where +> (b'', x') = f b' x +> (b', xs') = mapAccumR f b xs + +> mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list +> -- and accumulator, returning new +> -- accumulator and elt of result list +> -> acc -- Initial accumulator +> -> [x] -- Input list +> -> (acc, [y]) -- Final accumulator and result list +> +> mapAccumL f b [] = (b, []) +> mapAccumL f b (x:xs) = (b'', x':xs') where +> (b', x') = f b x +> (b'', xs') = mapAccumL f b' xs + +Here is the bi-directional version ... + +> mapAccumB :: (accl -> accr -> x -> (accl, accr,y)) +> -- Function of elt of input list +> -- and accumulator, returning new +> -- accumulator and elt of result list +> -> accl -- Initial accumulator from left +> -> accr -- Initial accumulator from right +> -> [x] -- Input list +> -> (accl, accr, [y]) -- Final accumulator and result list +> +> mapAccumB f a b [] = (a,b,[]) +> mapAccumB f a b (x:xs) = (a'',b'',y:ys) +> where +> (a',b'',y) = f a b' x +> (a'',b',ys) = mapAccumB f a' b xs + + +> assert False x = error "assert Failed" +> assert True x = x diff --git a/glafp-utils/nofib-analyse/Main.hs b/glafp-utils/nofib-analyse/Main.hs new file mode 100644 index 0000000..ad1a7ab --- /dev/null +++ b/glafp-utils/nofib-analyse/Main.hs @@ -0,0 +1,462 @@ +----------------------------------------------------------------------------- +-- $Id: Main.hs,v 1.1 1999/11/12 11:54:17 simonmar Exp $ + +-- (c) Simon Marlow 1997-1999 +----------------------------------------------------------------------------- + +module Main where + +import GenUtils +import Printf +import Slurp +import DataHtml +import CmdLine + +import GlaExts +import FiniteMap +import GetOpt + +import Char +import IO +import Array +import System +import List + +----------------------------------------------------------------------------- +-- Top level stuff + +die :: String -> IO a +die s = hPutStr stderr s >> exitWith (ExitFailure 1) + +usageHeader = "usage: nofib-analyse [OPTION...] ..." + +main = do + + if not (null cmdline_errors) || OptHelp `elem` flags + then die (concat cmdline_errors ++ usageInfo usageHeader argInfo) + else do + + let { html = OptHTMLOutput `elem` flags; + ascii = OptASCIIOutput `elem` flags + } + + if ascii && html + then die "Can't produce both ASCII and HTML" + else do + + results <- parse_logs other_args + + let column_headings = map (reverse . takeWhile (/= '/') . reverse) other_args + + if html + then putStr (renderHtml (htmlPage results column_headings)) + else putStr (asciiPage results column_headings) + + +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 -- 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 -> FiniteMap String a) -- get the module map + (a -> Bool) -- Result within reasonable limits? + +per_prog_result_tab = + [ SpecP "Binary Sizes" "binary-sizes" binary_size compile_status always_ok + , SpecP "Allocations" "allocations" allocs run_status always_ok + , SpecP "Run Time" "run-times" run_time run_status time_ok + , SpecP "Mutator Time" "mutator-time" mut_time run_status time_ok + , SpecP "GC Time" "gc-time" gc_time run_status time_ok + , SpecP "GC Work" "gc-work" gc_work run_status always_ok + , SpecP "Instructions" "instrs" instrs run_status always_ok + , SpecP "Memory Reads" "mem-reads" mem_reads run_status always_ok + , SpecP "Memory Writes" "mem-writes" mem_writes run_status always_ok + ] + +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 results args + = header [] (theTitle [] (htmlStr "NoFib Results")) + +++ bar [] + +++ gen_menu + +++ bar [] + +++ body [] (gen_tables results args) + +gen_menu = ul [] (foldr1 (+++) (map (li [] +++) + (map (prog_menu_item) per_prog_result_tab + ++ map (module_menu_item) per_module_result_tab))) + +prog_menu_item (SpecP name anc _ _ _) = anchor [href ('#':anc)] (htmlStr name) +module_menu_item (SpecM name anc _ _) = anchor [href ('#':anc)] (htmlStr name) + +gen_tables results args = + foldr1 (+++) (map (htmlGenProgTable results args) per_prog_result_tab) + +++ foldr1 (+++) (map (htmlGenModTable results args) per_module_result_tab) + +htmlGenProgTable results args (SpecP title anc get_result get_status result_ok) + = sectHeading title anc + +++ font [size 1] ( + mkTable (htmlShowResults results args get_result get_status result_ok)) + +++ bar [] + +htmlGenModTable results args (SpecM title anc get_result result_ok) + = sectHeading title anc + +++ font [size 1] ( + mkTable (htmlShowMultiResults results args get_result result_ok)) + +++ bar [] + +sectHeading :: String -> String -> Html +sectHeading s nm + = h2 [] (anchor [name nm] (htmlStr s)) + +htmlShowResults + :: Result a + => [ResultTable] + -> [String] + -> (Results -> Maybe a) + -> (Results -> Status) + -> (a -> Bool) + -> HtmlTable + +htmlShowResults (r:rs) ss f stat result_ok + = tabHeader ss + +/+ foldr1 (+/+) (zipWith tableRow [1..] results_per_prog) + +/+ tableRow (-1) ("Average", geometric_means) + where + -- results_per_prog :: [ (String,[BoxValue a]) ] + results_per_prog = map (calc_result rs f stat result_ok) (fmToList r) + + results_per_run = transpose (map snd results_per_prog) + geometric_means = map calc_gm results_per_run + +htmlShowMultiResults + :: Result a + => [ResultTable] + -> [String] + -> (Results -> FiniteMap String a) + -> (a -> Bool) + -> HtmlTable + +htmlShowMultiResults (r:rs) ss f result_ok = + multiTabHeader ss + +/+ foldr1 (+/+) (map show_results_for_prog base_results) + + where + base_results = fmToList r :: [(String,Results)] + + show_results_for_prog (prog,r) = + cellHtml [valign "top"] (bold [] (htmlStr prog)) + +-+ (if null base then + cellHtml [] (htmlStr "(no modules compiled)") + else + foldr1 (+/+) (map (show_one_result fms) base)) + + where + base = fmToList (f r) + fms = map (get_results_for prog) rs + + get_results_for prog m = case lookupFM m prog of + Nothing -> emptyFM + Just r -> f r + + show_one_result other_results (id,attribute) = + tableRow 0 ( + calc_result other_results Just (const Success) + result_ok (id,attribute) + ) + +tableRow :: Result a => Int -> (String, [BoxValue a]) -> HtmlTable +tableRow row_no (prog, results) + = cellHtml [bgcolor left_column_color] (htmlStr prog) + +-+ foldr1 (+-+) (map (cellHtml [align "right", clr] + . htmlStr . show_box) 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 = "#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 ss + = foldr1 (+-+) (map (\s -> cellHtml [align "right", width "100"] + (bold [] (htmlStr s))) ss) + +mkTable :: HtmlTable -> Html +mkTable = renderTable [cellspacing 0, cellpadding 0, border 0] + +tabHeader ss + = cellHtml [align "left", width "100"] (bold [] (htmlStr "Program")) + +-+ logHeaders ss + +multiTabHeader ss + = cellHtml [align "left", width "100"] (bold [] (htmlStr "Program")) + +-+ cellHtml [align "left", width "100"] (bold [] (htmlStr "Module")) + +-+ logHeaders ss + +-- Calculate a color ranging from bright blue for -100% to bright red for +100%. + +calcColor :: Int -> String +calcColor p | p >= 0 = "#" ++ (showHex red 2 "0000") + | otherwise = "#0000" ++ (showHex blue 2 "") + where red = p * 255 `div` 100 + blue = (-p) * 255 `div` 100 + +showHex 0 f s = if f > 0 then take f (repeat '0') ++ s else s +showHex i f s = showHex (i `div` 16) (f-1) (hexDig (i `mod` 16) : s) + +hexDig i | i > 10 = chr (i-10 + ord 'a') + | otherwise = chr (i + ord '0') + +----------------------------------------------------------------------------- +-- ASCII page generation + +asciiPage results args = + ( interleave "\n\n" (map (asciiGenProgTable results args) per_prog_result_tab) + . str "\n" + . interleave "\n\n" (map (asciiGenModTable results args) per_module_result_tab) + ) "\n" + +asciiGenProgTable results args (SpecP title anc get_result get_status result_ok) + = str title + . str "\n" + . ascii_show_results results args get_result get_status result_ok + +asciiGenModTable results args (SpecM title anc get_result result_ok) + = str title + . str "\n" + . ascii_show_multi_results results args get_result result_ok + +ascii_header ss + = str "\n-------------------------------------------------------------------------------\n" + . str (rjustify 15 "Program") + . str (space 5) + . foldr (.) id (map (str . rjustify fIELD_WIDTH) ss) + . str "\n-------------------------------------------------------------------------------\n" + +ascii_show_results + :: Result a + => [ResultTable] + -> [String] + -> (Results -> Maybe a) + -> (Results -> Status) + -> (a -> Bool) + -> ShowS + +ascii_show_results (r:rs) ss f stat result_ok + = ascii_header ss + . interleave "\n" (map show_per_prog_results results_per_prog) + . str "\n" + . show_per_prog_results ("Average",geometric_means) + where + -- results_per_prog :: [ (String,[BoxValue a]) ] + results_per_prog = map (calc_result rs f stat result_ok) (fmToList r) + + results_per_run = transpose (map snd results_per_prog) + geometric_means = map calc_gm results_per_run + +ascii_show_multi_results + :: Result a + => [ResultTable] + -> [String] + -> (Results -> FiniteMap String a) + -> (a -> Bool) + -> ShowS + +ascii_show_multi_results (r:rs) ss f result_ok + = ascii_header ss + . interleave "\n" (map show_results_for_prog base_results) + where + base_results = fmToList r :: [(String,Results)] + + show_results_for_prog (prog,r) = + str ("\n"++prog++"\n") + . (if null base then + str "(no modules compiled)\n" + else + interleave "\n" (map (show_one_result fms) base)) + + where + base = fmToList (f r) + fms = map (get_results_for prog) rs + + get_results_for prog m = case lookupFM m prog of + Nothing -> emptyFM + Just r -> f r + + show_one_result other_results (id,attribute) = + show_per_prog_results ( + calc_result other_results Just (const Success) + result_ok (id,attribute) + ) + +show_per_prog_results :: Result a => (String, [BoxValue a]) -> ShowS +show_per_prog_results (prog,results) + = str (rjustify 15 prog) + . str (space 5) + . foldr (.) id (map (str . rjustify fIELD_WIDTH . show_box) results) + +----------------------------------------------------------------------------- +-- Show the Results + +class Num a => Result a where + result_to_string :: a -> String + convert_to_percentage :: a -> a -> Float + +-- We assume an Int is a size, and print it in kilobytes. + +instance Result Int where + convert_to_percentage 0 size = 100 + convert_to_percentage base size = (fromInt size / fromInt base) * 100 + + result_to_string n = show (n `div` 1024) ++ "k" + +instance Result Integer where + convert_to_percentage 0 size = 100 + convert_to_percentage base size = (fromInteger size / fromInteger base) * 100 + + result_to_string n = show (n `quot` 1024) ++ "k" + +instance Result Float where + convert_to_percentage 0.0 size = 100.0 + convert_to_percentage base size = size / base * 100 + + result_to_string = showFloat' Nothing (Just 2) + +data BoxValue a = RunFailed Status | Percentage Float | Result a + +-- calc_result is a nice exercise in higher-order programming... +calc_result + :: Result a + => [FiniteMap String b] -- accumulated results + -> (b -> Maybe a) -- get a result from the b + -> (b -> Status) -- get a status from the b + -> (a -> Bool) -- is this result ok? + -> (String,b) -- the baseline result + -> (String,[BoxValue a]) + +calc_result rts get_maybe_a get_stat result_ok (prog,base_r) = + (prog, (just_result baseline base_stat : + + let + rts' = map (\rt -> get_stuff (lookupFM rt prog)) rts + + get_stuff Nothing = (Nothing, NotDone) + get_stuff (Just r) = (get_maybe_a r, get_stat r) + in + ( + case baseline of + Just base | result_ok base + -> map (\(r,s) -> percentage r s base) rts' + _other + -> map (\(r,s) -> just_result r s) rts' + ))) + where + baseline = get_maybe_a base_r + base_stat = get_stat base_r + + just_result Nothing s = RunFailed s + just_result (Just a) s = Result a + + percentage Nothing s base = RunFailed s + percentage (Just a) s base = Percentage + (convert_to_percentage base a) +show_box (RunFailed s) = show_stat s +show_box (Percentage p) = show_pcntage p +show_box (Result a) = result_to_string a + +----------------------------------------------------------------------------- +-- Calculating geometric means + +{- +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. +-} + +calc_gm :: [BoxValue a] -> BoxValue Float +calc_gm xs + | null percentages = RunFailed NotDone + | otherwise = Percentage (exp (sum (map log percentages) / + fromInt (length percentages))) + where + percentages = [ f | Percentage f <- xs, f /= 0.0 ] + -- can't do log(0.0), so exclude zeros + +----------------------------------------------------------------------------- +-- Generic stuff for results generation + +show_pcntage n = show_float_signed (n-100) ++ "%" + +show_float_signed = showFloat False False True False False Nothing (Just 2) + +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 = "-----" + +str = showString + +interleave s = foldr1 (\a b -> a . str s . b) + +fIELD_WIDTH = 16 :: Int + +----------------------------------------------------------------------------- diff --git a/glafp-utils/nofib-analyse/Makefile b/glafp-utils/nofib-analyse/Makefile new file mode 100644 index 0000000..7c2c08d --- /dev/null +++ b/glafp-utils/nofib-analyse/Makefile @@ -0,0 +1,7 @@ +TOP=.. +include $(TOP)/mk/boilerplate.mk + +SRC_HC_OPTS += -fglasgow-exts -syslib misc -cpp +HS_PROG = nofib-analyse + +include $(TOP)/mk/target.mk diff --git a/glafp-utils/nofib-analyse/OptTable.hs b/glafp-utils/nofib-analyse/OptTable.hs new file mode 100644 index 0000000..07cb339 --- /dev/null +++ b/glafp-utils/nofib-analyse/OptTable.hs @@ -0,0 +1,92 @@ +----------------------------------------------------------------------------- +-- $Id: OptTable.hs,v 1.1 1999/11/12 11:54:17 simonmar Exp $ +-- +-- OGI_Table : Class for combinators used in building 2D tables. +-- +-- Copyright (c) 1999 Andy Gill +-- +-- This module is distributed as Open Source software under the +-- Artistic License; see the file "Artistic" that is included +-- in the distribution for details. +----------------------------------------------------------------------------- + +module OptTable ( + OptTable, -- abstract + single, + beside, + above, + getMatrix, + ) where + +import qualified ClassTable as TC + +instance TC.Table OptTable where + single = OptTable.single + beside = OptTable.beside + above = OptTable.above + getMatrix = OptTable.getMatrix + +instance (Show a) => Show (OptTable a) where + showsPrec p = TC.showsTable + +type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]] + +data OptTable a = Table (Int -> Int -> TableI a) Int Int + +{- + - Perhaps one day I'll fell adventureous, and write the Show instance + - to show boxes aka the above ascii renditions. + -} + +-- You can create a (1x1) table entry +single :: a -> OptTable a +single a = Table (\ x y z -> [(a,(x+1,y+1))] : z) 1 1 + +-- You can compose tables, horizonally and vertically +above :: OptTable a -> OptTable a -> OptTable a +beside :: OptTable a -> OptTable a -> OptTable a + +t1 `above` t2 = trans (combine (trans t1) (trans t2) (.)) + +t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r -> + let + -- Note this depends on the fact that + -- that the result has the same number + -- of lines as the y dimention; one list + -- per line. This is not true in general + -- but is always true for these combinators. + -- I should assert this! + beside (x:xs) (y:ys) = (x ++ y) : beside xs ys + beside (x:xs) [] = x : xs ++ r + beside [] (y:ys) = y : ys ++ r + beside [] [] = r + in + beside (lst1 []) (lst2 [])) + +-- trans flips (transposes) over the x and y axis of +-- the table. It is only used internally, and typically +-- in pairs, ie. (flip ... munge ... (un)flip). + +trans :: OptTable a -> OptTable a +trans (Table f1 x1 y1) = Table (flip f1) y1 x1 + +combine :: OptTable a + -> OptTable b + -> (TableI a -> TableI b -> TableI c) + -> OptTable c +combine (Table f1 x1 y1) (Table f2 x2 y2) comb = Table new_fn (x1+x2) max_y + where + max_y = max y1 y2 + new_fn x y = + case compare y1 y2 of + EQ -> comb (f1 0 y) (f2 x y) + GT -> comb (f1 0 y) (f2 x (y + y1 - y2)) + LT -> comb (f1 0 (y + y2 - y1)) (f2 x y) + +-- This is the other thing you can do with a Table; +-- turn it into a 2D list, tagged with the (x,y) +-- sizes of each cell in the table. + +getMatrix :: OptTable a -> [[(a,(Int,Int))]] +getMatrix (Table r _ _) = r 0 0 [] + diff --git a/glafp-utils/nofib-analyse/Printf.lhs b/glafp-utils/nofib-analyse/Printf.lhs new file mode 100644 index 0000000..1fdc8c9 --- /dev/null +++ b/glafp-utils/nofib-analyse/Printf.lhs @@ -0,0 +1,56 @@ +----------------------------------------------------------------------------- +-- $Id: Printf.lhs,v 1.1 1999/11/12 11:54:17 simonmar Exp $ + +-- (c) Simon Marlow 1997-1999 +----------------------------------------------------------------------------- + +> module Printf (showFloat, showFloat') where + +> import GlaExts +> import PrelPack (unpackCString) + +> showFloat +> :: Bool -- Always print decimal point +> -> Bool -- Left adjustment +> -> Bool -- Always print sign +> -> Bool -- Leave blank before positive number +> -> Bool -- Use zero padding +> -> Maybe Int -- Field Width +> -> Maybe Int -- Precision +> -> Float +> -> String + +> bUFSIZE = 512 :: Int + +> showFloat alt left sign blank zero width prec num = +> unsafePerformPrimIO ( do +> buf <- _ccall_ malloc bUFSIZE :: IO Addr +> _ccall_ snprintf buf bUFSIZE format num +> let s = unpackCString buf +> length s `seq` -- urk! need to force the string before we +> -- free the buffer. A better solution would +> -- be to use foreign objects and finalisers, +> -- but that's just too heavyweight. +> _ccall_ free buf +> return s +> ) +> +> where +> format = '%' : +> if_bool alt "#" ++ +> if_bool left "-" ++ +> if_bool sign "+" ++ +> if_bool blank " " ++ +> if_bool zero "0" ++ +> if_maybe width show ++ +> if_maybe prec (\s -> "." ++ show s) ++ +> "f" + +> showFloat' :: Maybe Int -> Maybe Int -> Float -> String +> showFloat' = showFloat False False False False False + +> if_bool False s = [] +> if_bool True s = s + +> if_maybe Nothing f = [] +> if_maybe (Just s) f = f s diff --git a/glafp-utils/nofib-analyse/Slurp.hs b/glafp-utils/nofib-analyse/Slurp.hs new file mode 100644 index 0000000..92a0529 --- /dev/null +++ b/glafp-utils/nofib-analyse/Slurp.hs @@ -0,0 +1,354 @@ +----------------------------------------------------------------------------- +-- $Id: Slurp.hs,v 1.1 1999/11/12 11:54:17 simonmar Exp $ + +-- (c) Simon Marlow 1997-1999 +----------------------------------------------------------------------------- + +module Slurp (Status(..), Results(..), ResultTable(..), parse_log) where + +import CmdLine +import FiniteMap +import RegexString +import Maybe + +----------------------------------------------------------------------------- +-- This is the structure into which we collect our results: + +type ResultTable = FiniteMap String Results + +data Status + = NotDone + | Success + | OutOfHeap + | OutOfStack + | Exit Int + | WrongStdout + | WrongStderr + +data Results = Results { + compile_time :: FiniteMap String Float, + module_size :: FiniteMap String Int, + binary_size :: Maybe Int, + link_time :: Maybe Float, + run_time :: Maybe Float, + mut_time :: Maybe Float, + instrs :: Maybe Integer, + mem_reads :: Maybe Integer, + mem_writes :: Maybe Integer, + gc_work :: Maybe Integer, + gc_time :: Maybe Float, + allocs :: Maybe Integer, + run_status :: Status, + compile_status :: Status + } + +emptyResults = Results { + compile_time = emptyFM, + module_size = emptyFM, + binary_size = Nothing, + link_time = Nothing, + run_time = Nothing, + mut_time = Nothing, + instrs = Nothing, + mem_reads = Nothing, + mem_writes = Nothing, + gc_time = Nothing, + 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... +-} + +banner_re = mkRegex "^==nofib==[ \t]+([A-Za-z0-9_]+):[ \t]+(size of|time to link|time to run|time to compile)[ \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 = mkRegex "^[ \t]*([0-9.]+)[ \t]+real[ \t]+([0-9.]+)[ \t]+user[ \t]+([0-9.]+)[ \t]+sys[ \t]*$" + +size_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") +-} + +ghc1_re = mkRegex "^<>" + +ghc2_re = mkRegex "^<>" + +ghc3_re = mkRegex "^<>" + +ghc4_re = mkRegex "^<>" + +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)] -> FiniteMap String Results +combine_results = foldr f emptyFM + where + f (prog,results) fm = addToFM_C comb fm prog results + comb Results{ compile_time = ct1, link_time = lt1, + module_size = ms1, + run_time = rt1, mut_time = mt1, + instrs = is1, mem_reads = mr1, mem_writes = mw1, + gc_time = gt1, gc_work = gw1, + binary_size = bs1, allocs = al1, + run_status = rs1, compile_status = cs1 } + Results{ compile_time = ct2, link_time = lt2, + module_size = ms2, + run_time = rt2, mut_time = mt2, + instrs = is2, mem_reads = mr2, mem_writes = mw2, + gc_time = gt2, gc_work = gw2, + binary_size = bs2, allocs = al2, + run_status = rs2, compile_status = cs2 } + = Results{ compile_time = plusFM_C const ct1 ct2, + module_size = plusFM_C const ms1 ms2, + link_time = combMaybes lt1 lt2, + run_time = combMaybes rt1 rt2, + mut_time = combMaybes mt1 mt2, + instrs = combMaybes is1 is2, + mem_reads = combMaybes mr1 mr2, + mem_writes = combMaybes mw1 mw2, + gc_time = combMaybes gt1 gt2, + gc_work = combMaybes gw1 gw2, + binary_size = combMaybes bs1 bs2, + allocs = combMaybes al1 al2, + run_status = combStatus rs1 rs2, + compile_status = combStatus cs1 cs2 } + +combMaybes m1 m2 = case maybeToList m1 ++ maybeToList m2 of + [] -> Nothing + (x:_) -> Just x + +combStatus NotDone x = x +combStatus x NotDone = x +combStatus x y = 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 (prog : what : mod : _, chk) = + case what of + "time to compile" -> parse_compile_time prog mod chk + "time to run" -> parse_run_time prog (reverse chk) NotDone + "time to link" -> parse_link_time prog chk + "size of" -> parse_size prog mod chk + _ -> error ("process_chunk: "++what) + +parse_compile_time prog mod [] = [] +parse_compile_time prog mod (l:ls) = + case matchRegex time_re l of { + Just (real:user:system:_) -> + let ct = addToFM emptyFM mod (read user) + in + [(prog,emptyResults{compile_time = ct})]; + Nothing -> + + case matchRegex ghc1_re l of { + Just (allocs:_:_:_:_:init:_:mut:_:gc:_) -> + let + read_mut = read mut + read_gc = read gc + time = (read init + read_mut + read_gc) :: Float + ct = addToFM emptyFM mod time + in + [(prog,emptyResults{compile_time = ct})]; + Nothing -> + + case matchRegex ghc2_re l of { + Just (allocs:_:_:_:_:_:init:_:mut:_:gc:_) -> + let + read_mut = read mut + read_gc = read gc + time = (read init + read_mut + read_gc) :: Float + ct = addToFM emptyFM mod time + in + [(prog,emptyResults{compile_time = ct})]; + Nothing -> + + case matchRegex ghc3_re l of { + Just (allocs:_:_:_:_:_:_:init:_:mut:_:gc:_) -> + let + read_mut = read mut + read_gc = read gc + time = (read init + read_mut + read_gc) :: Float + ct = addToFM emptyFM mod time + in + [(prog,emptyResults{compile_time = ct})]; + Nothing -> + + case matchRegex ghc4_re l of { + Just (allocs:_:_:_:_:_:_:init:_:mut:_:gc:_:_:_:_) -> + let + read_mut = read mut + read_gc = read gc + time = (read init + read_mut + read_gc) :: Float + ct = addToFM emptyFM mod time + in + [(prog,emptyResults{compile_time = ct})]; + Nothing -> + + parse_compile_time prog mod ls + }}}}} + +parse_link_time prog [] = [] +parse_link_time prog (l:ls) = + case matchRegex time_re l of + Nothing -> parse_link_time prog ls + Just (real:user:system:_) -> + [(prog,emptyResults{link_time = Just (read user)})] + +parse_run_time prog [] NotDone = [] +parse_run_time prog [] ex =[(prog,emptyResults{run_status=ex})] +parse_run_time prog (l:ls) ex = + case matchRegex ghc1_re l of { + Just (allocs:_:_:_:_:init:_:mut:_:gc:_) -> + let + read_mut = read mut + read_gc = read gc + time = (read init + read_mut + read_gc) :: Float + in + [(prog,emptyResults{run_time = Just time, + mut_time = Just read_mut, + gc_time = Just read_gc, + allocs = Just (read allocs), + run_status = Success })]; + Nothing -> + + case matchRegex ghc2_re l of { + Just (allocs:_:_:_:_:_:init:_:mut:_:gc:_) -> + let + read_mut = read mut + read_gc = read gc + time = (read init + read_mut + read_gc) :: Float + in + [(prog,emptyResults{run_time = Just time, + mut_time = Just read_mut, + gc_time = Just read_gc, + allocs = Just (read allocs), + run_status = Success })]; + Nothing -> + + case matchRegex ghc3_re l of { + Just (allocs:_:_:_:_:gc_work:_:init:_:mut:_:gc:_) -> + let + read_mut = read mut + read_gc = read gc + read_gc_work = read gc_work + time = (read init + read_mut + read_gc) :: Float + in + [(prog,emptyResults{run_time = Just time, + mut_time = Just read_mut, + gc_work = Just read_gc_work, + gc_time = Just read_gc, + allocs = Just (read allocs), + run_status = Success })]; + Nothing -> + + case matchRegex ghc4_re l of { + Just (allocs:_:_:_:_:gc_work:_:init:_:mut:_:gc:_:is:mem_rs:mem_ws:_) -> + let + read_mut = read mut + read_gc = read gc + read_gc_work = read gc_work + time = (read init + read_mut + read_gc) :: Float + in + [(prog,emptyResults{run_time = Just time, + mut_time = Just read_mut, + gc_work = Just read_gc_work, + gc_time = Just read_gc, + instrs = Just (read is), + mem_writes = Just (read mem_ws), + mem_reads = Just (read mem_rs), + allocs = Just (read allocs), + run_status = Success })]; + Nothing -> + + case matchRegex wrong_output l of { + Just ("stdout":_) -> + parse_run_time prog ls (combineRunResult WrongStdout ex); + Just ("stderr":_) -> + parse_run_time prog ls (combineRunResult WrongStderr ex); + Nothing -> + + case matchRegex wrong_exit_status l of { + Just (wanted:got:_) -> + parse_run_time prog ls (combineRunResult (Exit (read got)) ex); + Nothing -> + + case matchRegex out_of_heap l of { + Just _ -> + parse_run_time prog ls (combineRunResult OutOfHeap ex); + Nothing -> + + case matchRegex out_of_stack l of { + Just _ -> + parse_run_time prog ls (combineRunResult OutOfStack ex); + Nothing -> + parse_run_time prog ls ex; + + }}}}}}}} + +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 prog mod [] = [] +parse_size prog mod (l:ls) = + case matchRegex size_re l of + Nothing -> parse_size prog mod ls + Just (text:datas:bss:_) + | prog == mod -> + [(prog,emptyResults{binary_size = + Just (read text + read datas), + compile_status = Success})] + | otherwise -> + let ms = addToFM emptyFM mod (read text) + in + [(prog,emptyResults{module_size = ms})] + -- 1.7.10.4